Compare two datasets in Excel VBA

Question

I made the following code to take two reports and compares them to show the end user elements which are missing from one of the reports so they can make the adjustments needed.

This is the main part of the process where the data within the two reports are processed and it's working with around 85K lines in one report and 60K lines in the other which are located on sheet1 and sheet2 within the same workbook (an earlier macro clears and pulls the data in from where they live.

It's taking around 15 minutes to run (I've got a quad core machine, with 4gb of ram. takes over an hour to run on the older dual core machines in the office). Still easier than running it manually but it was suggested that this could be run in seconds with some improvements.

Sub processdata()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    Dim XXXXLen As Long
    With Sheets("Input - XXXXwebnew")
        XXXXLen = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    'add concatenate ref column in column A on Input XXXXWebNew

    Sheets("INPUT - XXXXwebnew").Select
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Sheets("INPUT - XXXXwebnew").Range("A1:A" & XXXXLen) = "=CONCATENATE(E1,""_"",G1,""_"",I1)"
    Application.Calculate
    Sheets("Input - XXXXwebnew").Range("a1:a" & XXXXLen).Copy
    Sheets("Input - XXXXwebnew").Range("a1:a" & XXXXLen).PasteSpecial xlPasteValues

    'picks up config products and moves them from E (input - XXXXwebnew) to to A on (workings) tab

    Workbooks("workingmodel.xlsm").Sheets("WORKINGS").Range("a2:a" & XXXXLen + 1).value _
        = Workbooks("workingmodel.xlsm").Sheets("INPUT - XXXXWebNew").Range("e1:e" & XXXXLen).value

    'picks up simple products and moves them from A (input - XXXXwebnew) to to A on (workings) tab

    'set a second dim which is the dim XXXXlen X2

    Dim XXXXlen2 As Long
    XXXXlen2 = XXXXLen + XXXXLen

    Workbooks("workingmodel.xlsm").Sheets("WORKINGS").Range("a" & XXXXLen + 2 & ":a" & XXXXlen2 + 1).value _
        = Workbooks("workingmodel.xlsm").Sheets("INPUT - XXXXWebNew").Range("a1:a" & XXXXLen).value

    'remove all duplicates

    Sheets("workings").Range("$A$1:$A$" & XXXXlen2 + 1).RemoveDuplicates Columns:=1, Header:=xlYes

    'dim set for Workings tab length of data

    Dim WorkLen As Long
    With Sheets("WORKINGS")
        WorkLen = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    'brings first formula in, calculates, C&Psp

    Sheets("workings").Range("b2:b" & WorkLen) = "=IF(LEN(A2)=12,""CONFIG"",""SIMPLE"")"
    Application.Calculate
    Sheets("workings").Range("b2:b" & WorkLen).Copy
    Sheets("workings").Range("b2:b" & WorkLen).PasteSpecial xlPasteValues

    'Sheets("workings").Range("c1") = "does it appear within XXXX_all(code means yes / #N/A means no)"

    'define lenght of XXXX_all
    Dim XXXXallLen As Long
    With Sheets("INPUT - XXXX_all")
        XXXXallLen = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    'building the various dimensions required for a dynamic vba vlookup

    Dim sheetXXXX_all As String
    sheetXXXX_all = "INPUT - XXXX_all"

    Dim XXXXalllookup As String
    XXXXalllookup = ("'" & sheetXXXX_all & "'!$A$1:$m$" & XXXXallLen)

    Sheets("workings").Range("c2:c" & WorkLen) = "=left(VLOOKUP(A2," & XXXXalllookup & ",1,FALSE),12)"
    Application.Calculate
    Sheets("workings").Range("c2:c" & WorkLen).Copy
    Sheets("workings").Range("c2:c" & WorkLen).PasteSpecial xlPasteValues


    'Sheets("workings").Range("d1") = "is it enabled"


    Sheets("workings").Range("d2:d" & WorkLen) = "=VLOOKUP(A2," & XXXXalllookup & ",2,FALSE)"
    Application.Calculate
    Sheets("workings").Range("d2:d" & WorkLen).Copy
    Sheets("workings").Range("d2:d" & WorkLen).PasteSpecial xlPasteValues


    'Sheets("workings").Range("e1") = "does it have an image 0 = no #N/A = product code doesn't exist"

    Sheets("workings").Range("e2:e" & WorkLen) = "=VLOOKUP(A2," & XXXXalllookup & ",4,FALSE)"
    Application.Calculate
    Sheets("workings").Range("e2:e" & WorkLen).Copy
    Sheets("workings").Range("e2:e" & WorkLen).PasteSpecial xlPasteValues


    'Sheets("workings").Range("f1") = "does description has a character"

    Sheets("workings").Range("f2:f" & WorkLen) = "=IF(LEN(VLOOKUP(A2," & XXXXalllookup & ",4,FALSE))=0,""NO DESC"",""FINE"")"
    Application.Calculate
    Sheets("workings").Range("f2:f" & WorkLen).Copy
    Sheets("workings").Range("f2:f" & WorkLen).PasteSpecial xlPasteValues

    'Sheets("workings").Range("g1") = "RRRP Price"

    Sheets("workings").Range("g2:g" & WorkLen) = "=IF(VLOOKUP(A2," & XXXXalllookup & ",6,FALSE)<0.1,""NO PRICE"",""PRICE EXISTS"")"
    Application.Calculate
    Sheets("workings").Range("g2:g" & WorkLen).Copy
    Sheets("workings").Range("g2:g" & WorkLen).PasteSpecial xlPasteValues

    'Sheets("workings").Range("h1") = "UK Price"

    Sheets("workings").Range("h2:h" & WorkLen) = "=IF(VLOOKUP(A2," & XXXXalllookup & ",13,FALSE)<0.1,""NO PRICE"",""PRICE EXISTS"")"
    Application.Calculate
    Sheets("workings").Range("h2:h" & WorkLen).Copy
    Sheets("workings").Range("h2:h" & WorkLen).PasteSpecial xlPasteValues

    'Sheets("workings").Range("I1") = "Current stock greater than 0"

    Sheets("workings").Range("i2:i" & WorkLen).FormulaR1C1 = "=IF(RC[-7]=""config"",IF(SUMIF('Input - XXXXwebnew'!C[-4],WORKINGS!RC[-8],'Input - XXXXwebnew'!C[11])<0.1,""NO STOCK"",""HAS STOCK""),IF(VLOOKUP(RC[-8],'Input - XXXXwebnew'!C[-8]:C[12],20,FALSE)>0,""HAS STOCK"",""NO STOCK""))"
    Application.Calculate
    Sheets("workings").Range("i2:i" & WorkLen).Copy
    Sheets("workings").Range("i2:i" & WorkLen).PasteSpecial xlPasteValues

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub

jkpieterse · Accepted Answer · 2017-03-23 13:29:31Z

2

One possible speedup would be to remove all copy/ pastespecial values and just do a single one at the end, just after turning calculation back on:

Sheets("workings").Range("C2:I" & WorkLen).Value2 = Sheets("workings").Range("C2:I" & WorkLen).Value2

In addition, since you are looking up the same information over and over (all VLOOKUP functions share the same first arguments), you should consider adding a column which holds the MATCH function and from the other columns use its result as an argument for the INDEX function.

So suppose we'll use column Z for the MATCH:

Sheets("workings").Range("Z2:Z" & WorkLen) = "=MATCH(A2," & XXXXalllookup & ",0)"

Then column D would become (it fetches its data from col B):

Sheets("workings").Range("d2:d" & WorkLen) = "=INDEX(" & "'" & sheetXXXX_all & "'!$B$1:$B$" & XXXXallLen & ",Z2)"

answered Mar 23, 2017 at 13:29

jkpieterse

1664 bronze badges

\$\begingroup\$ Hi @jkpieterse thanks for your response. both suggestions make perfect sense now they're shown to me. I'll try these on Monday when back in the office and report back! thanks again \$\endgroup\$

plan303
– plan303

03/25/2017 13:12:51
Commented Mar 25, 2017 at 13:12
\$\begingroup\$ Good morning, I replaced the vlookups with the index formula you suggested. Also I replaced the calculations with one final calculation at the end. This has reduced the time taken from approx. 15minutes down to approx. 6 mins. The final sumif is causing the majority of the remaining wait time, I'm going to continue working on this and attempt to use the index solution as part of the vlookup nested in the sumif. Again thanks for assistance \$\endgroup\$

plan303
– plan303

03/27/2017 10:56:47
Commented Mar 27, 2017 at 10:56

Add a comment |

Stack Exchange Network

Compare two datasets in Excel VBA

1 Answer 1

Your Answer

Hot Network Questions

Compare two datasets in Excel VBA

1 Answer 1

Your Answer

Sign up or log in

Post as a guest

Related

Hot Network Questions