Copy/Paste rows to matching named sheet

Question

I have a worksheet "List" which has rows of data that I need to copy to other worksheets. In column "J" of "List", there is a name (Matthew, Mark, Linda, etc.) that designates who's data that row is.

Each of those names (22 in all) has a matching spreadsheet with the same name. I want all rows that say "Linda" in column "J" to paste to worksheet "Linda", all rows with "Matthew" to paste to worksheet "Matthew", etc.

I have some code below, which mostly works, but I'd have to rewrite it for all 22 names/sheets.

Is there a way to loop through all the sheets, pasting the rows with matching names? Also, the code below works really slowly, and I'm using data sets with anywhere from 200 to 60,000 rows that need sorted and pasted, which means that if its slow on a small data set like the one I'm currently working on, and only for one sheet, it's going to be glacially slow for the big data sets.

Sub CopyMatch()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = Worksheets("List")
    Set Target = Worksheets("Linda")

    j = 4     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("J4:J1000")   ' Do 1000 rows
        If c = "Linda" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

Answer 1

Unless you've turned calculation off somewhere we can't see here, then every time you copy a row, Excel is recalculating - even if your sheets contain no formulas.

If you're not doing so already, simply putting:

application.calculation=xlcalculationmanual

before you start your loop and:

application.calculation=xlcalculationautomatic

after exiting the loop will massively speed up your loop. For extra swank, you can use a variable to store the calculation setting before you turn it off and restore that setting at the end, e.g.

dim lCalc as long
lCalc = application.calculation
application.calculation = xlcalculationmanual
for ... next goes here
application.calculation = lCalc

Also consider other settings, e.g.: application.screenupdating=False|True.

Sort the data by the name you're selecting on, then by any other sorts you want. That way you can skip through any size sheet in 22 steps (since you say you have 22 names).

How you copy the data depends on preference and how much data there is. Copying one row at a time is economical on memory and pretty much guaranteed to work, but is slower. Or you can identify the top and bottom rows of each person's data and copy the whole block as a single range, at the risk of exceeding the memory available on large blocks in large sheets.

Assuming the value in your name column, for the range you're checking, is always one of the 22 names, then if you've sorted first by that column you can use the value in that column to determine the destination, e.g.:

dim sTarget as string
dim rng as range
sTarget = ""
For Each c In Source.Range("J4:J1000") ' Do 1000 rows
    if c <> "" then ' skip empty rows
        if c <> sTarget then ' new name block
            sTarget = c
            Set Target = Worksheets(c)
            set rng = Target.cells(Target.rows.count, 10).end(xlup) ' 10="J"
            j = rng.row + 1 ' first row below last name pasted
        end if
        Source.Rows(c.Row).Copy Target.Rows(j)
        j = j + 1
    end if
Next

This is economical of memory because you're going row by row, but still reasonably fast because you're only recalculating Target and resetting j when the name changes.

Answer 2

you could use:

• Dictionary object to quickly build the list of unique names out of column J names

• AutoFilter() method of Range object for filtering on each name:

as follows

    Option Explicit

    Sub CopyMatch()
        Dim c As Range, namesRng As Range
        Dim name As Variant

        With Worksheets("List") '<--| reference "List" worskheet
            Set namesRng = .Range("J4", .Cells(.Rows.count, "J").End(xlUp)) '<--| set the range of "names" in column "J" starting from row 4 down to last not empty row
        End With

        With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
            For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "names" range cells with text content only
                .item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
            Next
            Set namesRng = namesRng.Resize(namesRng.Rows.count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
            For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
                FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
            Next
        End With '<--| release the 'Dictionary' object
    End Sub

    Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
        Dim destsht As Worksheet

        Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
        With rangeToFilter
            .AutoFilter Field:=1, Criteria1:=nameToFilter
            Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.count, "J").End(xlUp)
            .Parent.AutoFilterMode = False
        End With
    End Sub