Needed help in running the macro very urgent

[kausikmohan]

Hi Folks,

I am new here, Needed a very urgent help.

I have developed a macro where it pulls the data from WorkBook 2 based on Criteria in Workbook 1. Macro is running fine but it takes more time to populate the data for me since the Workbook 2 *SERP DATA DUMP" is a 61 MB file.

Can someone help me ASAP? as I need to present this one in tomorrow's meeting.

Thanks in advance.

Sub Filter&Paste()
Dim wsData As Worksheet
Dim wsMacro As Worksheet
Dim sToFind As String
Dim sFirstAddress As String
Dim nr As Long, lr As Long
Dim rFind As Range
Set wsData = Workbooks("SERP Data Dump.xlsm").Sheets("Data")
Set wsMacro = Workbooks("Preliminary SERP SOA template.xlsm").Sheets("FBL Data")

lr = wsData.Range("F" & Rows.Count).End(xlUp).Row
sToFind = wsMacro.Range("A1").Value
nr = wsMacro.Range("A" & Rows.Count).End(xlUp).Row + 1
Set rFind = wsData.Range("F1:F" & lr).Find(What:=sToFind)

If rFind Is Nothing Then
MsgBox sToFind & " could not be found in Column F", vbInformation, "Not Found"
Exit Sub
End If
sFirstAddress = rFind.Address
Do
rFind.EntireRow.Copy
wsMacro.Range("A" & nr).PasteSpecial xlPasteAll
nr = nr + 1
Set rFind = wsData.Range("F1:F" & lr).FindNext(After:=rFind)
Loop Until rFind.Address = sFirstAddress
Set rFind = Nothing
Set wsData = Nothing
Set wsMacro = Nothing

Rows("3:3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
End Sub

[offthelip]

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.

I have made an effort to rewrite your routine using variant arrays ,I haven't been able to test it but it should show you how to do it, it will probably at least 1000 times faster ( I do mean 1000 times faster).

Sub FilterPaste()
Dim wsData As Worksheet
Dim wsMacro As Worksheet
Dim sToFind As String
Dim sFirstAddress As String
Dim nr As Long, lr As Long
Dim rFind As Range
Set wsData = Workbooks("SERP Data Dump.xlsm").Sheets("Data")
Set wsMacro = Workbooks("Preliminary SERP SOA template.xlsm").Sheets("FBL Data")


With Worksheets(wsData)
Lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
lr = .Cells(Rows.Count, "A").End(xlUp).Row
dataws = .Range(.Cells(1, 1), .Cells(Lr, Lc))
End With
' define an output array which is big enough to take  the maximum possible number of rows
Dim outarr(1 To lr, 1 To lc) As Variant
indi = 1
sToFind = wsMacro.Range("A1").Value
nr = wsMacro.Range("A" & Rows.Count).End(xlUp).Row + 1
foundf = False
loop through data looking for string
For i = 1 To lr
 If dataws(i, 6) = sToFind Then
  ' copy this row to output array
   foundf = True
' copy data to macro
   For j = 1 To Lc
    outarr(indi, j) = dataws(i, j)
   Next j
   indi = indi + 1
 End If
Next i
If Not (foundf) Then
MsgBox sToFind & " could not be found in Column F", vbInformation, "Not Found"
Exit Sub
End If
' write the array back to the worksheet
With Worksheets(wsMacro)
 .Range(.Cells(nr, 1), .Cells(nr + indi, Lc)) = outarr
End With

' do whatever this did to tidy  I haven't changed this
Set rFind = Nothing
Set wsData = Nothing
Set wsMacro = Nothing


Rows("3:3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
End Sub

[kausikmohan]

Thank you so much