How to copy row to another sheet if the cell value of C matches the sheetname

Question

So I pull data then I have to copy and paste the rows to their respective sheets basing on the value of Column D. I have a code that does the thing but it takes too slow when there are thousands of rows.

Sub COPY_DATA()

    Dim bottomD As Long
    bottomD = Range("D" & Rows.Count).End(xlUp).Row
    Dim c As Range
    Dim ws As Worksheet
    For Each c In Sheets("Data").Range("D2:D" & bottomD)
        For Each ws In Sheets
            ws.Activate
            If ws.Name = c And ws.Name <> "Userform" Then
                c.EntireRow.copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Next ws
    Next c

Worksheets("Data").Activate

End Sub

I want to make the process of copy and pasting faster

You can disable screen updates, `Application.ScreenUpdating = False`, copy your data, and then enable screen updates `Application.ScreenUpdating = True`. This will speed up the copy. See [Effect of Screen Updating](https://stackoverflow.com/questions/12391786/effect-of-screen-updating). — RobertBaron, Aug 06 '19 at 21:23

score 1 · Answer 1 · answered Aug 06 '19 at 21:36

This should be faster:

Sub COPY_DATA()

    Dim dict As Object
    Dim bottomD As Long
    Dim c As Range
    Dim ws As Worksheet,wb as workbook, wsData as Worksheet

    Set wb = ActiveWorkbook
    Set wsData = wb.worksheets("Data")

    'collect the sheet names
    Set dict = CreateObject("scripting.dictionary")
    For Each ws In wb.Worksheets
        If ws.Name <> "Userform" Then dict.Add ws.Name, True
    Next ws

    Application.ScreenUpdating = False

    bottomD = wsData.Range("D" & Rows.Count).End(xlUp).Row
    For Each c In wsData.Range("D2:D" & bottomD)
        If dict.exists(c.Value) Then
            c.EntireRow.Copy wb.Worksheets(c.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next c

    Application.ScreenUpdating = True

    wsData.Activate

End Sub

score 0 · Answer 2 · answered Aug 06 '19 at 21:33

Stop .Activating! Totally unnecessary and updating the UI is taking time. Make sure all calls to ranges are qualified.

Option Explicit '<--- Always at the top of modules!
Sub COPY_DATA()

    Dim bottomD As Long
    bottomD = Range("D" & Rows.Count).End(xlUp).Row
    Dim c As Range
    Dim ws As Worksheet
    For Each c In Sheets("Data").Range("D2:D" & bottomD)
        For Each ws In Sheets
            With ws
                If .Name = c.Value And .Name <> "Userform" Then
                    c.EntireRow.copy Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            End With
        Next ws
    Next c
End Sub

Note also that I explicitly stated c.Value instead of using the implicit/default property (which just happens to be Value).

How to copy row to another sheet if the cell value of C matches the sheetname

2 Answers2