Copy Rows to a certain Column

[Jessica553]

Hello,
I am trying to tell VBA to copy all the rows that contain the name 'Chris' to a sheet called 'Chris' and then Rob, Andrew etc.
But I want it to just copy from Column A to K. At the moment it's working but with the entire row. Is there a way to change this to just go up to column K?

Sub CopyRow2()
'Declare variables
Dim sheetNo1 As Worksheet
Dim sheetNo2 As Worksheet
Dim sheetNo3 As Worksheet
Dim sheetNo4 As Worksheet
Dim sheetNo5 As Worksheet
Dim sheetNo6 As Worksheet
Dim FinalRow As Long
Dim Cell As Range
'Set variables
Set sheetNo1 = Sheets("DataDump")
Set sheetNo2 = Sheets("Chris")
Set sheetNo3 = Sheets("Rob")
Set sheetNo4 = Sheets("Andrew")
Set sheetNo5 = Sheets("Charlie")
Set sheetNo6 = Sheets("Terry")
'Type a command to select the entire row
Selection.EntireRow.Select
' Define destination sheets to move row
FinalRow1 = sheetNo1.Range("A" & sheetNo1.Rows.Count).End(xlUp).Row
FinalRow2 = sheetNo2.Range("A" & sheetNo2.Rows.Count).End(xlUp).Row
FinalRow3 = sheetNo3.Range("A" & sheetNo3.Rows.Count).End(xlUp).Row
FinalRow4 = sheetNo4.Range("A" & sheetNo4.Rows.Count).End(xlUp).Row
FinalRow5 = sheetNo5.Range("A" & sheetNo5.Rows.Count).End(xlUp).Row
FinalRow5 = sheetNo5.Range("A" & sheetNo5.Rows.Count).End(xlUp).Row
With sheetNo1
'Apply loop for column J until last cell with value
For Each Cell In .Range("J1:J" & .Cells(.Rows.Count, "J").End(xlUp).Row)
'Apply condition to match the "Chris" value
If Cell.Value = "Chris" Then
'Command to Copy and move to a destination Sheet "Chris"
.Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)
FinalRow2 = FinalRow2 + 1
'Apply condition to match the "Rob" value
ElseIf Cell.Value = "Rob" Then
'Command to Copy and move to a destination Sheet "Rob"
.Rows(Cell.Row).Copy Destination:=sheetNo3.Rows(FinalRow3 + 1)
FinalRow3 = FinalRow3 + 1
'Apply condition to match the "Andrew" value
ElseIf Cell.Value = "Andrew" Then
'Command to Copy and move to a destination Sheet "Andrew"
.Rows(Cell.Row).Copy Destination:=sheetNo4.Rows(FinalRow4 + 1)
FinalRow4 = FinalRow4 + 1
'Apply condition to match the "Charlie" value
ElseIf Cell.Value = "Charlie" Then
'Command to Copy and move to a destination Sheet "Charlie"
.Rows(Cell.Row).Copy Destination:=sheetNo5.Rows(FinalRow5 + 1)
FinalRow5 = FinalRow5 + 1
'Apply condition to match the "Terry" value
ElseIf Cell.Value = "Terry" Then
'Command to Copy and move to a destination Sheet "Terry"
.Rows(Cell.Row).Copy Destination:=sheetNo6.Rows(FinalRow6 + 1)
FinalRow6 = FinalRow6 + 1
End If
Next Cell
End With
End Sub

 

[kevin9999]

Try this with a copy of your data

Option Explicit
Sub Jessica553()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("DataDump")
    Dim lRow As Long, i As Long
    Dim sName
    
    sName = Array("Chris", "Rob", "Andrew", "Charlie", "Terry")
    
    For i = LBound(sName) To UBound(sName)
        Set ws2 = Worksheets(sName(i))
        lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A1").CurrentRegion
            .AutoFilter 10, sName(i)
            .Offset(1).Resize(, 11).Copy ws2.Cells(lRow, 1)
            .AutoFilter
        End With
    Next i
End Sub

 

[Jessica553]

Hello Kevin,
Thank you for the quick reply. I did receive an error about the Autofilter field. Could this be because my data doesn't start until row 5? I couldn't figure out any other reason.

 

[kevin9999]

Hello Kevin,
Thank you for the quick reply. I did receive an error about the Autofilter field. Could this be because my data doesn't start until row 5? I couldn't figure out any other reason.

Yes that would do it. Is it data headers that are on row 5? A quick screenshot would help.

 

[Jessica553]

Yes data headers and space for the buttons.

 

[kevin9999]

It looks like your headers are on row 4? That being the case, try this:

Option Explicit
Sub Jessica553_2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("DataDump")
    Dim lRow As Long, i As Long
    Dim sName
    
    sName = Array("Chris", "Rob", "Andrew", "Charlie", "Terry")
    
    For i = LBound(sName) To UBound(sName)
        Set ws2 = Worksheets(sName(i))
        lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A4").CurrentRegion
            .AutoFilter 10, sName(i)
            .Offset(1).Resize(, 11).Copy ws2.Cells(lRow, 1)
            .AutoFilter
        End With
    Next i
End Sub

 

[johnnyL]

Another thing to try, I haven't tested it ...

Sub CopyRow2()
'
'Declare variables
    Dim Cell        As Range
    Dim sheetNo1    As Worksheet, sheetNo2  As Worksheet, sheetNo3  As Worksheet
    Dim sheetNo4    As Worksheet, sheetNo5  As Worksheet, sheetNo6  As Worksheet
'
'Set variables
    Set sheetNo1 = Sheets("DataDump")
    Set sheetNo2 = Sheets("Chris")
    Set sheetNo3 = Sheets("Rob")
    Set sheetNo4 = Sheets("Andrew")
    Set sheetNo5 = Sheets("Charlie")
    Set sheetNo6 = Sheets("Terry")
'
'Type a command to select the entire row
''    Selection.EntireRow.Select
'
    With sheetNo1
        For Each Cell In .Range("J1:J" & .Cells(.Rows.Count, "J").End(xlUp).Row)                                                                '   Apply loop for column J until last cell with value
            Select Case Cell.Value
                Case "Chris": .Range("A" & Cell.Row & ":K" & Cell.Row).Copy sheetNo2.Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)     '       Apply condition to match the "Chris" value
                Case "Rob": .Range("A" & Cell.Row & ":K" & Cell.Row).Copy sheetNo3.Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)       '       Apply condition to match the "Rob" value
                Case "Andrew": .Range("A" & Cell.Row & ":K" & Cell.Row).Copy sheetNo4.Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)    '       Apply condition to match the "Andrew" value
                Case "Charlie": .Range("A" & Cell.Row & ":K" & Cell.Row).Copy sheetNo5.Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)   '       Apply condition to match the "Charlie" value
                Case "Terry": .Range("A" & Cell.Row & ":K" & Cell.Row).Copy sheetNo6.Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)     '       Apply condition to match the "Terry" value
            End Select
        Next Cell                                                                                                                               '   Loop back
    End With
End Sub

 

[Jessica553]

Hi Kevin,
I tried the first option however it has given me a variable not defined error.
I also tried replacing it all with the second option, however it didn't like that and copied only the columns J and K by the look of it.

 

[kevin9999]

Hi Kevin,
I tried the first option however it has given me a variable not defined error.
I also tried replacing it all with the second option, however it didn't like that and copied only the columns J and K by the look of it.

Was the error message actually "Variable Not Defined", and which line did it occur on? Strange, because all variables used were defined.

The second option copies the columns from A:K on the test data I set up. If I'm going to assist you any further, I'll need to see the actual sheet (you can fill with dummy data to protect privacy etc.) using the XL2BB tool. Unfortunately, I can't copy the URL for some reason at present.

 

[tmskipper86]

Try this with a copy of your data

Option Explicit
Sub Jessica553()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("DataDump")
    Dim lRow As Long, i As Long
    Dim sName
   
    sName = Array("Chris", "Rob", "Andrew", "Charlie", "Terry")
   
    For i = LBound(sName) To UBound(sName)
        Set ws2 = Worksheets(sName(i))
        lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A1").CurrentRegion
            .AutoFilter 10, sName(i)
            .Offset(1).Resize(, 11).Copy ws2.Cells(lRow, 1)
            .AutoFilter
        End With
    Next i
End Sub

Hello. I am trying to do the same thing. Only difference is I have 50+ sheets (1 for each state and some more for countries). Is there a way to maybe loop through until all data is copied to corresponding sheets? I attached pictures.