copy rows from 1sheet to another using VBA

July 1, 2010 at 03:10:23
Specs: Windows XP
Hi,
I need a VBA code that will copy rows from 1 sheet to another as follows.

Column A has country names.
If cell A2 = spain then copy this row to sheets"Spain". etc.

then goto the next row and copy the row to the sheet that contains the country name in cell A3....etc
thanks for your help
Katrin


See More: copy rows from 1sheet to another using VBA

Report •


#1
July 1, 2010 at 07:42:02
Do the country sheets already exist?

Do you want the rows copied to the next empty row in each sheet?

Is there anything else that we should be aware of before we spend time writing code?


Report •

#2
July 1, 2010 at 08:10:45
Hi,

First look at the questions in this post, and respond with the answers. As DerbyDad03 said, Is there anything else that we should be aware of before we spend time writing code?

These answers make a big difference to what code is written or modified.

For now, here is one I wrote for someone else.
It may work for you.
Note that the source data worksheet must be named "Source" for this code to work:

Option Explicit

Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

With Worksheets("Source")
    'set start as A2 i.e., after heading row in column A
    Set rngStart = .Range("A2")
    'set end - last used row in column Q
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)
    
    'loop through cells in column A
    For Each rngCell In Range(rngStart, rngEnd)
        'test if tab exists
        On Error Resume Next
        If Not Worksheets(rngCell.Text).Name <> "" Then
            On Error GoTo ErrHnd
            'No worksheet of this name - so create one and copy row
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = rngCell.Text
            rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("A1")
            Else
            On Error GoTo ErrHnd
            'worksheet exists
            'copy row to end of used range
            rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text).Range("A1") _
                    .Offset(Worksheets(rngCell.Text).UsedRange.Rows.Count, 0)
        End If
    Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

As always, test this on a copy of your data as changes made by macros cannot be undone with the undo function.
Always make a backup copy before running the macro.

Regards


Report •

#3
July 6, 2010 at 02:14:01
Hi,

thank you both for the code, It is working as it should.

thanks so much
Katrin


Report •

Related Solutions

#4
July 6, 2010 at 04:12:25
Hi,

Thanks for the feedback.
Glad to hear it's working.

Regards

Humar


Report •

#5
August 5, 2010 at 01:08:51
Grate code Humar, but I have a litle problem with the results.
If I have for example several sheets with the names; Apple, Orange, Banana and Grape.
Lets say the source sheet have 4 rows for eatch fruit...

My result will then be that I only get the last row from Apple, but the other sheets present all 4 rows.

When run in debug mode it seams like the results for the first sheet (rngStart) over-writes the result in the same cells, when for the other sheets the rows are pasted on different rows, as intended.

Do you know why I get this result?


Report •

#6
August 5, 2010 at 05:50:23
Hi,

It's likely due to the way UsedRange works.

My guess is that on the worksheet that does not work, cell A1 is empty and UsedRange does not return the expected range information.

Anyway here is the code using a different way to find where to paste rows of data after the first row.

Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

With Worksheets("Source")
    'set start as A2 i.e., after heading row in column A
    Set rngStart = .Range("A2")
    'set end - last used row in column Q
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)
    
    'loop through cells in column A
    For Each rngCell In Range(rngStart, rngEnd)
        'test if tab exists
        On Error Resume Next
        If Not Worksheets(rngCell.Text).Name <> "" Then
            On Error GoTo ErrHnd
            'No worksheet of this name - so create one and copy row
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = rngCell.Text
            rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text) _
                    .Range("A1")
            Else
            On Error GoTo ErrHnd
            'worksheet exists
            'copy row to end of used range
            rngCell.EntireRow.Copy _
                    Destination:=Worksheets(rngCell.Text) _
                    .Range("A" & CStr(Application.Rows.Count)).End(xlUp) _
                    .Offset(1, 0)
        End If
    Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

Regards


Report •

#7
October 7, 2010 at 02:33:59
Hi,

i used this code as it works for me too. Basically each day i will get a report showing a series of results and i input this into the "source" sheet. Therefore the code above looks for the Department Name (A2) and pulls the rows from the source sheet into the tab that has the same department name. However i do need some help to go a step further. I would like a userform that has 3 options:

1. Edit the workbook (so i can go in and enter the new data each day)
2. Run all results (so the code provided by Humar pulls all the results into the correct tabs - NOTE: i already have the code inputed)
3. Show Specific Campaign Results ( This is where i need a dropdown box for all campaign names - i have a hidden tab with these on it thats also hidden from VBA )
4. Run

With number 3 i need a code that basically looks at column B in the "source" tab and if it finds a campaign name the same as the one chosen from the dropdown box then to pull these rowns into a new sheet.

Is this possible and if so can anyone help???


Report •

#8
January 27, 2011 at 10:39:40
Hello,I like the code written below, not sure by who originally, but the header row dosn't copy over (it creates a separate sheet for the header), this is after I changed the macro to start in A6 rather than A2. Is there a way to have the macro copy and past the first 6 rows from the source sheet as a header then to begin copying and pasting each row of data begining in row 7 from the source sheet?

I would also like to apply subtotals to column G thru I, K thru M and O thru P, based on column F values. Not sure if this is possible or not.


This is the code I am currently working off:
Public Sub MoveToTab()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range

On Error GoTo ErrHnd

With Worksheets("Source")
'set start as A2 i.e., after heading row in column A
Set rngStart = .Range("A2")
'set end - last used row in column Q
Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'loop through cells in column A
For Each rngCell In Range(rngStart, rngEnd)
'test if tab exists
On Error Resume Next
If Not Worksheets(rngCell.Text).Name <> "" Then
On Error GoTo ErrHnd
'No worksheet of this name - so create one and copy row
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = rngCell.Text
rngCell.EntireRow.Copy Destination:=Worksheets(rngCell.Text) _
.Range("A1")
Else
On Error GoTo ErrHnd
'worksheet exists
'copy row to end of used range
rngCell.EntireRow.Copy _
Destination:=Worksheets(rngCell.Text) _
.Range("A" & CStr(Application.Rows.Count)).End(xlUp) _
.Offset(1, 0)
End If
Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub



Report •


Ask Question