VBA: Copy rows to unique sheets

[sachavez]

Looking for a way to copy data from specific rows to specific sheets.

Example:

Look at Column K for name, and copy the data for that row in to it's own (already created) tab.

If the name "Smith" is in column, that row goes to the Smith tab, etc.

My data set is in the "Working Copy" sheet.

Thanks in advance.

Steve

 

[Fluff]

Everytime you run the macro will the other sheets be empty?
If not do you want to clear the existing data, or add the new data below the old?

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, lastRow As Long, ws As Worksheet, item As Variant
    Set RngList = CreateObject("Scripting.Dictionary")
    lastRow = Sheets("Working Copy").Cells(Rows.Count, "K").End(xlUp).Row
    For Each Rng In Sheets("Working Copy").Range("K2:K" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each item In RngList
        With Sheets("Working Copy")
            .Range("K1:K" & lastRow).AutoFilter Field:=1, Criteria1:=item
            .Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(item).Cells(Sheets(item).Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range("K1").AutoFilter
        End With
    Next item
    Application.ScreenUpdating = True
End Sub

 

[sachavez]

sheets are empty.

 

[sachavez]

Mumps, worked like a champ. Problem solved. Thank you very much!

Steve

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, lastRow As Long, ws As Worksheet, item As Variant
    Set RngList = CreateObject("Scripting.Dictionary")
    lastRow = Sheets("Working Copy").Cells(Rows.Count, "K").End(xlUp).Row
    For Each Rng In Sheets("Working Copy").Range("K2:K" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each item In RngList
        With Sheets("Working Copy")
            .Range("K1:K" & lastRow).AutoFilter Field:=1, Criteria1:=item
            .Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(item).Cells(Sheets(item).Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range("K1").AutoFilter
        End With
    Next item
    Application.ScreenUpdating = True
End Sub

 

[mumps]

You are very welcome. Every time you run the macro, the existing rows will be added to the existing data. You should consider Fluff's question if it applies:

do you want to clear the existing data, or add the new data below the old?

 

[Fluff]

Assuming this is related to your previous thread, you can create the sheets & copy data across in one code like

Sub sachavez()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Ky As Variant
   
   Set Ws = Sheets("Working Copy")
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("K2", Ws.Range("K" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A1:K1").AutoFilter 11, Ky
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Ws.AutoFilter.Range.EntireRow.Copy Sheets(Ky).Range("A1")
      Next Ky
   End With
   Ws.AutoFilterMode = False
End Sub