Could I have done this quicker?

[Poundland]

Hi All,

Created and ran a macro code, it did what required but took 90minutes to run through, for future reference could there have been quicker way of doing this?


Sub qa_check()
Dim rngSku As Range, rngQa As Range, wrkThis As Workbook, wrkQA As Workbook
Dim rngHaz As Range, rngDestn As Range
Application.Calculation = xlCalculationManual
Set wrkThis = ThisWorkbook
Set wrkQA = Workbooks("QAWorkflowDeptGreaterThan500.csv")
Set rngQa = wrkQA.Sheets("QAWorkflowDeptGreaterThan500").Range("A:A")
For Each rngSku In wrkThis.Sheets(1).Range(Cells(2, 1), Cells(2, 1).End(xlDown)) ' Has 43000 unique records
With rngQa
On Error Resume Next
Set rngHaz = .Find(rngSku, , , xlWhole).Offset(, 1).Resize(, 14) ' Has 147000 unique records to search through
On Error GoTo 0
If Not rngHaz Is Nothing Then
Set rngDestn = rngSku.Offset(, 1).Resize(, 14)
rngHaz.Copy rngDestn
End If
End With

Set rngHaz = Nothing
Next rngSku
Application.Calculation = xlCalculationAutomatic
End Sub

[大灰狼1976]

Hi Poundland!
I think using array + dictionary can reduce the time by at least 90%.

[Poundland]

Hi Poundland!
I think using array + dictionary can reduce the time by at least 90%.

And how would I do that?

[Bob Phillips]

Can't be sure without seeing the data, but Power Query will probably be quicker and better.

[大灰狼1976]

Sorry, there is no excel in my pc now, I can only give you a brief explanation (if you understand the dictionary).
1. Assign data from 147000 rows and 15 columns to an array(Suppose its name is arrOriginal).
2. Assign arrOriginal to dictionary(named dic): key=arrOriginal(row,1), item=row
3. Assign data from 43000 rows to another array(named arrResult). then resize it to 15 columns(redim preserve)
4. Traversing the first column of arrResult, Use dic to get row numbers in another arrOriginal(Or it doesn't exist in dic)
5. Extracting data from matching rows in arrOriginal to arrResult(Or do not extract)
6. Output arrResult to range

[Poundland]

Sorry, there is no excel in my pc now, I can only give you a brief explanation (if you understand the dictionary).
1. Assign data from 147000 rows and 15 columns to an array(Suppose its name is arrOriginal).
2. Assign arrOriginal to dictionary(named dic): key=arrOriginal(row,1), item=row
3. Assign data from 43000 rows to another array(named arrResult). then resize it to 15 columns(redim preserve)
4. Traversing the first column of arrResult, Use dic to get row numbers in another arrOriginal(Or it doesn't exist in dic)
5. Extracting data from matching rows in arrOriginal to arrResult(Or do not extract)
6. Output arrResult to range

I understood about 60% of that but have no idea how to code it.

[snb]

Sub M_snb()
sn = ThisWorkbook.Sheets(1).Columns(1).SpecialCells(2).Resize(, 14)
sp = Workbooks("QAWorkflowDeptGreaterThan500.csv").Sheets("QAWorkflowDeptGreaterThan500").Columns(1).SpecialCells(2).Resize(, 14)

For j = 2 To UBound(sn)
For jj = 1 To UBound(sp)
If sn(j, 1) = sp(jj, 1) Then Exit For
Next
If jj <= UBound(sp) Then
For jjj = 2 To 14
sn(j, jjj) = sp(jj, jjj)
Next
End If
Next

ThisWorkbook.Sheets(1).Columns(1).SpecialCells(2).Resize(, 14) = sn
End Sub

[Poundland]

Sub M_snb()
sn = ThisWorkbook.Sheets(1).Columns(1).SpecialCells(2).Resize(, 14)
sp = Workbooks("QAWorkflowDeptGreaterThan500.csv").Sheets("QAWorkflowDeptGreaterThan500").Columns(1).SpecialCells(2).Resize(, 14)

For j = 2 To UBound(sn)
For jj = 1 To UBound(sp)
If sn(j, 1) = sp(jj, 1) Then Exit For
Next
If jj <= UBound(sp) Then
For jjj = 2 To 14
sn(j, jjj) = sp(jj, jjj)
Next
End If
Next

ThisWorkbook.Sheets(1).Columns(1).SpecialCells(2).Resize(, 14) = sn
End Sub


I had to change the 14 to 15 so to get all the required data, but did the trick, and took about 15 minutes as opposed to nearly 2 hours..

I just need to understand it now...

[大灰狼1976]

This code can reduce processing time to 10 seconds on your computer.

Sub qa_check()
Dim arrOriginal, arrResult, dic As Object, i&, j&, r&
Set dic = CreateObject("scripting.dictionary")
With Workbooks("QAWorkflowDeptGreaterThan500.csv").Sheets("QAWorkflowDeptGreaterThan500")
arrOriginal = .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row).Resize(, 15)
End With
For i = 2 To UBound(arrOriginal) 'Suppose have head line
dic(arrOriginal(i, 1)) = i
Next i
With ThisWorkbook.Sheets(1)
arrResult = .Range("a2:a" & .Cells(Rows.Count, 1).End(3).Row) 'Suppose have head line
ReDim Preserve arrResult(1 To UBound(arrResult), 1 To 15)
End With
For i = 1 To UBound(arrResult)
r = dic(arrResult(i, 1))
If r > 0 Then
For j = 2 To 15
arrResult(i, j) = arrOriginal(r, j)
Next j
End If
Next i
ThisWorkbook.Sheets(1).[a2].Resize(UBound(arrResult), 15) = arrResult
End Sub

[Poundland]

This code can reduce processing time to 10 seconds on your computer.

Sub qa_check()
Dim arrOriginal, arrResult, dic As Object, i&, j&, r&
Set dic = CreateObject("scripting.dictionary")
With Workbooks("QAWorkflowDeptGreaterThan500.csv").Sheets("QAWorkflowDeptGreaterThan500")
arrOriginal = .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row).Resize(, 15)
End With
For i = 2 To UBound(arrOriginal) 'Suppose have head line
dic(arrOriginal(i, 1)) = i
Next i
With ThisWorkbook.Sheets(1)
arrResult = .Range("a2:a" & .Cells(Rows.Count, 1).End(3).Row) 'Suppose have head line
ReDim Preserve arrResult(1 To UBound(arrResult), 1 To 15)
End With
For i = 1 To UBound(arrResult)
r = dic(arrResult(i, 1))
If r > 0 Then
For j = 2 To 15
arrResult(i, j) = arrOriginal(r, j)
Next j
End If
Next i
ThisWorkbook.Sheets(1).[a2].Resize(UBound(arrResult), 15) = arrResult
End Sub

Well that was super super quick, again I just need to understand it so I can replicate it...