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
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
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).
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.