Is it possible to make it faster? VBA copy and paste when condition is met

[Pimo]

Hi!

I have a problem with macro running too slow and I guess it is just because of lack of my knowledge.

I have a macro that is copying data from "database" and paste it to another sheet.
Macro is taking the names from the list in Sheet1 and looks for matches in Sheet2. When the match is found is copying a specific cell.

Right now I have a macro for each person on the list so I have 5 the same macros doing the same thing so maybe that why it takes so much time....

Is there any way to make it faster?
below my code so far and sample sheet



Sub CopySalesMan1()


Dim lastrow As Long, erow As Long


lastrow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row


For i = 2 To lastrow


If Worksheets("Sheet2").Cells(i, 25).Value = Worksheets("Sheet1").Cells(6, 12).Value Then


Worksheets("Sheet2").Cells(i, 2).Copy


erow = Worksheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row


Worksheets("Sheet1").Cells(erow + 1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Worksheets("Sheet2").Cells(i, 25).Copy


Worksheets("Sheet1").Cells(erow + 1, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Worksheets("Sheet2").Cells(i, 3).Copy


Worksheets("Sheet1").Cells(erow + 1, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Worksheets("Sheet2").Cells(i, 4).Copy


Worksheets("Sheet1").Cells(erow + 1, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Worksheets("Sheet2").Cells(i, 5).Copy


Worksheets("Sheet1").Cells(erow + 1, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Worksheets("Sheet2").Cells(i, 6).Copy


Worksheets("Sheet1").Cells(erow + 1, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Worksheets("Sheet2").Cells(i, 21).Copy


Worksheets("Sheet1").Cells(erow + 1, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False








End If


Next i


End Sub



Sub All()

If Worksheets("Sheet1").Range("L7").Value <> "" Then Call CopySalesMan2
If Worksheets("Sheet1").Range("L8").Value <> "" Then Call CopySalesMan3
If Worksheets("Sheet1").Range("L9").Value <> "" Then Call CopySalesMan4
If Worksheets("Sheet1").Range("L10").Value <> "" Then Call CopySalesMan5




End Sub

27731

[macropod]

Perhaps:


Sub CopySalesMan()
Application.ScreenUpdating = False
Dim XlWkSht As Worksheet, sVal As String, lRow As Long, i As Long, r As Long
Set XlWkSht = Worksheets("Sheet1")
lRow = XlWkSht.Range("D" & XlWkSht.Rows.Count).End(xlUp).Row
For i = 6 To 10
If XlWkSht.Range("L" & i).Value <> "" Then
sVal = XlWkSht.Range("L" & i).Value
With Worksheets("Sheet2")
For r = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
If .Range("Y" & r).Text = sVal Then
lRow = lRow + 1
XlWkSht.Range("C" & lRow).Value = .Range("B" & r).Value
XlWkSht.Range("D" & lRow).Value = .Range("Y" & r).Value
XlWkSht.Range("E" & lRow).Value = .Range("C" & r).Value
XlWkSht.Range("F" & lRow).Value = .Range("D" & r).Value
XlWkSht.Range("G" & lRow).Value = .Range("E" & r).Value
XlWkSht.Range("H" & lRow).Value = .Range("F" & r).Value
XlWkSht.Range("I" & lRow).Value = .Range("U" & r).Value
End If
Next r
End With
End If
Next
Application.ScreenUpdating = True
End Sub

[Pimo]

Yes! that helped a lot!

macro running time dropped from 220s to 26s!

[snb]

Which is still ridiculously slow.


Sub CopySalesMan1()
With Sheets("sheet2").Cells(1).CurrentRegion
.AutoFilter 25, Sheets("Sheet1").Cells(6, 12)
.Offset(1).Copy Sheets("Sheet1").Cells(Rows.Count, 4).Offset(1, -1)
.AutoFilter
End With
End Sub

[macropod]

Which is still ridiculously slow.


Sub CopySalesMan1()
With Sheets("sheet2").Cells(1).CurrentRegion
.AutoFilter 25, Sheets("Sheet1").Cells(6, 12)
.Offset(1).Copy Sheets("Sheet1").Cells(Rows.Count, 4).Offset(1, -1)
.AutoFilter
End With
End Sub
Way better than useless code that:
(a) doesn't work at all; and
(b) even if it did work, doesn't address the OP's requirements.

In any event, even with 100 data rows to process, my code takes less than 1 second to complete on my laptop. I have no idea why it might take so long on the OP's system.

[Pimo]

Well the code is a part of a bigger macro so probably that's why it is taking more time than on yours.

I changed a little bit the rest of the code and I was able to go to 16s

P.S original data has around 5k rows...

Anyway thanks for help!