Converting my Range code to Array (need lots of help!)

[eleehl]

Hi All, I am very new to VBA but lately I have the task of trying to comparing a column based on another column that has a unique ID between 2 files. The first file is what we call a pre-migration report and the second file is a post-migration report. The objective of this code is to see if there are changes. I have written the code with ranges initially. While it works on small files, it stalls on larger files. Sometimes large files can have 20,000+ rows. The structure in simplified term looks like the below. I need to be able to detect changes in for example 3rd column only since that can change. I have figured out how to convert my existing macro to array by detecting unique IDs that are new or deleted between pre and post reports but I didn't have any success in converting the code to array to compare column 3 changes while utilizing the unique ID. The code in red is what I want to convert to array, assuming this will run faster and not stall my computer everytime I run it. Any help is appreciated!!

Pre-Report

UniqueID	Status1	Status2	Status3
1	Open	Open	Open
2	Open	Open	Open
3	Closed	Closed	Closed
4	Closed	Closed	Closed
5	Closed	Closed	Closed
6	Closed	Closed	Closed
7	Closed	Closed	Closed
8	Closed	Closed	Closed
9	Closed	Closed	Closed

<tbody>
</tbody>

Post-Report

UniqueID	Status1	Status2	Status3
1	Open	Open	Closed
2	Open	Open	Open
3	Closed	Closed	Closed
4	Closed	Closed	Closed
5	Closed	Closed	Closed
6	Closed	Closed	Closed
7	Closed	Closed	Closed
8	Closed	Closed	Closed
9	Closed	Closed	Open

<tbody>
</tbody>

This is my original code for the comparison of the status column

Dim strFileToOpen1 As String
Dim strFileToOpen2 As String
Dim preQSR_WB As Workbook
Dim postQSR_WB As Workbook
Dim preQSRsheet As Worksheet
Dim PostQSRsheet As Worksheet
Dim col As Range
Dim f As Range
Dim PreQueryID As Range
Dim PostQueryID As Range
Dim PreQueryID_row As Integer
Dim PostQueryID_row As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim DataRng As Range
Dim DataRng2 As Range
Dim countchange1 As Integer
Dim countchange2 As Integer
Dim countchange3 As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim exists As Boolean
Dim existingsheet As Worksheet

countchange1 = 0
countchange2 = 0
countchange3 = 0

Dim PostQSRsheet2 As Worksheet




'Open the file dialog
strFileToOpen1 = Application.GetOpenFilename(Title:="Please choose the pre-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


'Checking if file is selected


If strFileToOpen1 = "" Then
MsgBox "No files selected.", vbExclamation, "Sorry!"
'And exiting from the procedure
Exit Sub
Else


strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


If strFileToOpen2 = strFileToOpen1 Then
MsgBox "The post-QSR file you have selected have the same filename as the pre-QSR file.", vbExclamation, "Please choose again"
   strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")
Else


'Opening the file if selected in the above step
Workbooks.Open Filename:=strFileToOpen1
Workbooks.Open Filename:=strFileToOpen2


'Assign variable to opened worksheets
Set preQSR_WB = Workbooks.Open(Filename:=strFileToOpen1)
Set postQSR_WB = Workbooks.Open(Filename:=strFileToOpen2)
Set preQSRsheet = preQSR_WB.Sheets("Sheet1")
Set PostQSRsheet = postQSR_WB.Sheets("Sheet1")




End If


End If






PreQueryID_row = preQSRsheet.Application.WorksheetFunction.Match("Query ID", Range("j1:j10000"), 0)
PostQueryID_row = PostQSRsheet.Application.WorksheetFunction.Match("Query ID", Range("j1:j10000"), 0)




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


For Each existingsheet In postQSR_WB.Sheets
 exists = False
 
    If existingsheet.Name = "Comparison Report" Then
    
    exists = True
    MsgBox ("Sorry please delete/rename exisiting 'Comparison Report' worksheet first before continuing")
    Exit For
    Exit Sub
    
    Else
    exists = False
    
    End If
Next existingsheet
 
 If exists = False Then
  
 postQSR_WB.Worksheets.Add.Name = "Comparison Report"
 Worksheets("Comparison Report").Move After:=Sheets(postQSR_WB.Sheets.Count)
 
 Else
 
 Exit Sub
 
 End If

For a = PreQueryID_row To preQSRsheet.Range("j" & Rows.Count).End(xlUp).Row

       Match = False
        Set rng1 = preQSRsheet.Range("j" & a)



        For b = PostQueryID_row To PostQSRsheet.Range("j" & Rows.Count).End(xlUp).Row

            Set rng2 = PostQSRsheet.Range("j" & b)

            If rng1 = rng2 Then

                Match = True


                     If preQSRsheet.Cells(a, 15).Value = PostQSRsheet.Cells(b, 15).Value Then

                     ElseIf preQSRsheet.Cells(a, 15).Value = "Open" And PostQSRsheet.Cells(b, 15).Value = "Closed" Then

                     preQSRsheet.Cells(a, 15).Interior.ColorIndex = 6
                     PostQSRsheet.Cells(b, 15).Interior.ColorIndex = 6
                     PostQSRsheet.Cells(b, 20).Value = "This query was opened in pre-QSR"
                     PostQSRsheet.Cells(b, 20).Interior.ColorIndex = 6
                     countchange1 = countchange1 + 1

                     ElseIf preQSRsheet.Cells(a, 15).Value = "Closed" And PostQSRsheet.Cells(b, 15).Value = "Open" Then

                     preQSRsheet.Cells(a, 15).Interior.ColorIndex = 6
                     PostQSRsheet.Cells(b, 15).Interior.ColorIndex = 6
                     PostQSRsheet.Cells(b, 20).Value = "This query was closed in pre-QSR"
                     PostQSRsheet.Cells(b, 20).Interior.ColorIndex = 6
                     countchange2 = countchange2 + 1

                     Else
                     PostQSRsheet.Cells(b, 15).Interior.ColorIndex = 6
                     PostQSRsheet.Cells(b, 20).Value = "This query has changed"
                     PostQSRsheet.Cells(b, 20).Interior.ColorIndex = 6
                     countchange3 = countchange3 + 1
                     End If


            End If

        Next b



 Next a


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


MsgBox ("Comparison Completed" & vbCrLf & vbCrLf & "There are " & countchange1 & " Open queries closed in post-QSR" & vbCrLf & "There are " & countchange2 & " Closed queries opened in post-QSR" & vbCrLf & "There are " & countchange3 & " miscellaneous queries in Query Status column")

This is my code after I have converted. I know it's a bit of a mess but I've been really pulling my hair out over the past couple of days trying to convert...the original code works just not efficient and maybe that's why it's been stalling when I have in excess 20k+ rows.

Any help would be appreciated on how to convert the second part.

Sub Array_Compare_QSR()






Dim strFileToOpen1 As String
Dim strFileToOpen2 As String
Dim preQSR_WB As Workbook
Dim postQSR_WB As Workbook
Dim preQSRsheet As Worksheet
Dim PostQSRsheet As Worksheet
'Dim col As Range
'Dim f As Range
Dim PreQueryID As Range
Dim PostQueryID As Range
Dim PreQueryID_find
Dim PostQueryID_find
Dim PreQueryStatus_find
Dim PostQueryStatus_find


Dim PreQueryID_row As Long
Dim PostQueryID_row As Long
Dim PreQueryStatus_row As Long
Dim PostQueryStatus_row As Long
Dim firstrng As Range, secondrng As Range, thirdrng As Range, fourthrng As Range




Dim rng1 As Range
Dim rng2 As Range




Dim LastRow As Long
Dim lngCNT As Long
Dim lngCNT2 As Long


Dim var1 As Variant, var2 As Variant, x
Dim firstArray As Variant, secondarray As Variant, thirdarray As Variant, fourtharray As Variant, y
Dim SearchRange1 As Range, SearchRange2 As Range
Dim FindRow As Range
Dim PostQSRsheet2 As Worksheet




'Open the file dialog
strFileToOpen1 = Application.GetOpenFilename(Title:="Please choose the pre-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


'Checking if file is selected


If strFileToOpen1 = "" Then
MsgBox "No files selected.", vbExclamation, "Sorry!"
'And exiting from the procedure
Exit Sub
Else


strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


If strFileToOpen2 = strFileToOpen1 Then
MsgBox "The post-QSR file you have selected have the same filename as the pre-QSR file.", vbExclamation, "Please choose again"
   strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")
Else


'Opening the file if selected in the above step
Workbooks.Open Filename:=strFileToOpen1
Workbooks.Open Filename:=strFileToOpen2


'Assign variable to opened worksheets
Set preQSR_WB = Workbooks.Open(Filename:=strFileToOpen1)
Set postQSR_WB = Workbooks.Open(Filename:=strFileToOpen2)
Set preQSRsheet = preQSR_WB.Sheets("Sheet1")
Set PostQSRsheet = postQSR_WB.Sheets("Sheet1")
postQSR_WB.Worksheets.Add.Name = "Sheet2"
Set PostQSRsheet2 = postQSR_WB.Sheets("Sheet2")




End If


End If






Set PreQueryID_find = preQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")
Set PostQueryID_find = postQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")


Set PreQueryStatus_find = preQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")
Set PostQueryStatus_find = postQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")


PreQueryID_row = PreQueryID_find.Row
PostQueryID_row = PostQueryID_find.Row
PreQueryStatus_row = PreQueryStatus_find.Row
PostQueryStatus_row = PostQueryStatus_find.Row




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


PostQSRsheet2.Range("A1:D1").Value = Array("In Pre but not in Post", "In Post but Not in Pre", "Open in Pre Closed in Post", "Closed in Pre Open in Post")


'sheet1 range and fill array
With preQSRsheet
        LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        
        Set rng1 = preQSRsheet.Range("J1:J" & LastRow)
        
        var1 = rng1


        Set firstrng = preQSRsheet.Range("j1:j" & LastRow)
        firstArray = firstrng1
     
        Set secondrng = preQSRsheet.Range("o1:j" & LastRow)
        secondarray = secondrng


End With


'sheet2 range and fill array
With PostQSRsheet


        LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        
        Set rng2 = PostQSRsheet.Range("J1:J" & LastRow)
        var2 = rng2
        
        Set thirdrng = PostQSRsheet.Range("j1:j" & LastRow)
        thirdarray = thirdrng
     
        Set fourthrng = PostQSRsheet.Range("o1:j" & LastRow)
        fourtharray = fourthrng
End With


'check preQSR against postQSR
On Error GoTo NoMatch1
For lngCNT = PreQueryID_row To UBound(var1)
x = Application.WorksheetFunction.Match(var1(lngCNT, 1), rng2, False)
 'MsgBox x
 'Exit Sub
 Next
 
 
 'check postQSR against preQSR
 
 On Error GoTo NoMatch2
 For lngCNT = PostQueryID_row To UBound(var2)
 x = Application.WorksheetFunction.Match(var2(lngCNT, 1), rng1, False)
 'MsgBox x
 'Exit Sub
 Next
 
 
 For lngCNT2 = PreQueryID_row To UBound(firstArray)
      y = Application.WorksheetFunction.Match(firstArray(lngCNT, 1), thirdrng, False)
      If y > 0 Then
      On Error GoTo NoMatch3
      z = Application.WorksheetFunction.Match(secondarray(lngCNT, 1), fourthrng, False)
         If z > 0 Then
      Else
      End If
      End If
Next
 
 On Error GoTo 0
 








'**********************************************************************************************
'compare Query Status column
'need 2 arrays








Application.ScreenUpdating = True
Exit Sub
      
NoMatch1:


PostQSRsheet2.Range("A" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = var1(lngCNT, 1)
Resume Next


NoMatch2:


PostQSRsheet2.Range("B" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = var2(lngCNT, 1)
Resume Next
      
      
NoMatch3:


PostQSRsheet2.Range("C" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(lngCNT2, 1)
Resume Next

 

[RickXL]

Hi and welcome to the MrExcel Message Board.

If it were me, and if you are using Windows then I would probably use a Dictionary Object. Dictionaries are a bit like a two column array. The first column contains a key and the second can be anything. So, in this case, I would load it with all the keys and all the values in the column you want to monitor for changes.

The easiest and quickest way to get a lot of data from the worksheet into VBA is to use a Variant as an array. Then it is possible to load the Dictionary from that array very quickly with a For/Next loop.

The code below does that for both worksheets.

Then it loops over the data in column 4 of one sheet and compares it with the data in the Dictionary for the other worksheet. It notes the differences in another Varant/Array called out1. It creates out2 for the other sheet similarly.

Finally, it outputs out1 and out2 into column 5 of the original sheets. They will now contain comments like: Same, Changed and Missing. "Missing" is when the key is not found in the other worksheet.

Sub Compare()
    Dim ary1    As Variant
    Dim ary2    As Variant
    Dim out1    As Variant
    Dim out2    As Variant
    Dim dic1    As Object
    Dim dic2    As Object
    Dim i       As Long
    
    With ThisWorkbook.Worksheets("Pre-Report")
        ary1 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
        Set dic1 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ary1)
            dic1(ary1(i, 1)) = ary1(i, 4)
        Next
    End With
    
    With ThisWorkbook.Worksheets("Post-Report")
        ary2 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
        Set dic2 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ary2)
            dic2(ary2(i, 1)) = ary2(i, 4)
        Next
    End With
    
    ReDim out1(1 To UBound(ary1), 1 To 1)
    For i = 1 To UBound(ary1)
        If dic2.exists(ary1(i, 1)) Then
            If dic2(ary1(i, 1)) = ary1(i, 4) Then out1(i, 1) = "Same" Else out1(i, 1) = "Changed"
        Else
            out1(i, 1) = "Missing"
        End If
    Next
    
    ReDim out2(1 To UBound(ary2), 1 To 1)
    For i = 1 To UBound(ary2)
        If dic1.exists(ary2(i, 1)) Then
            If dic1(ary2(i, 1)) = ary2(i, 4) Then out2(i, 1) = "Same" Else out2(i, 1) = "Changed"
        Else
            out2(i, 1) = "Missing"
        End If
    Next
    
    With ThisWorkbook.Worksheets("Pre-Report")
        .Range("E2").Resize(UBound(out1)) = out1
    End With
    
    With ThisWorkbook.Worksheets("Post-Report")
        .Range("E2").Resize(UBound(out2)) = out2
    End With
End Sub

Regards,

 

[eleehl]

Thanks RickXL, this is quite an elegant way to write it! I haven't used dictionary before. I didn't see your post till now but on Friday I figured the code below. Not as clean as yours but reading 20K rows takes about 45 sec. Still not the best according to what I have seen on this forum. I will be taking your code and incorporating it into mine. Thanks!

Sub Array_Compare_QSR()


Dim strFileToOpen1 As String
Dim strFileToOpen2 As String
Dim preQSR_WB As Workbook
Dim postQSR_WB As Workbook
Dim preQSRsheet As Worksheet
Dim PostQSRsheet As Worksheet
Dim PreQueryID As Range
Dim PostQueryID As Range
Dim PreQueryID_find
Dim PostQueryID_find
Dim PreQueryStatus_find
Dim PostQueryStatus_find
Dim PreQueryID_row As Long
Dim PostQueryID_row As Long
Dim PreQueryStatus_row As Long
Dim PostQueryStatus_row As Long
Dim firstrng As Range, secondrng As Range, thirdrng As Range, fourthrng As Range
Dim LastRow As Long
Dim firstArray As Variant, secondarray As Variant, thirdarray As Variant, fourtharray As Variant, y
Dim PostQSRsheet2 As Worksheet


'Open the file dialog
strFileToOpen1 = Application.GetOpenFilename(Title:="Please choose the pre-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


'Checking if file is selected
If strFileToOpen1 = "" Then
MsgBox "No files selected.", vbExclamation, "Sorry!"
'And exiting from the procedure
Exit Sub
Else


strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


If strFileToOpen2 = strFileToOpen1 Then
MsgBox "The post-QSR file you have selected have the same filename as the pre-QSR file.", vbExclamation, "Please choose again"
   strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")
Else


'Opening the file if selected in the above step
Workbooks.Open Filename:=strFileToOpen1
Workbooks.Open Filename:=strFileToOpen2


'Assign variable to opened worksheets
Set preQSR_WB = Workbooks.Open(Filename:=strFileToOpen1)
Set postQSR_WB = Workbooks.Open(Filename:=strFileToOpen2)
Set preQSRsheet = preQSR_WB.Sheets("Sheet1")
Set PostQSRsheet = postQSR_WB.Sheets("Sheet1")
postQSR_WB.Worksheets.Add.Name = "Report2"
Set PostQSRsheet2 = postQSR_WB.Sheets("Report2")


End If
End If


Set PreQueryID_find = preQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")
Set PostQueryID_find = postQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")


Set PreQueryStatus_find = preQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")
Set PostQueryStatus_find = postQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")


PreQueryID_row = PreQueryID_find.Row
PostQueryID_row = PostQueryID_find.Row
PreQueryStatus_row = PreQueryStatus_find.Row
PostQueryStatus_row = PostQueryStatus_find.Row
'MsgBox PreQueryID_row
'Exit Sub


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


PostQSRsheet2.Range("C1:E1").Value = Array("Query ID", "Pre-QSR Query Status", "Post-QSR Status")


LastRow = preQSRsheet.Range("j" & Rows.Count).End(xlUp).Row
Set firstrng = preQSRsheet.Range("j1:j" & LastRow)
firstArray = firstrng


LastRow = preQSRsheet.Range("o" & Rows.Count).End(xlUp).Row
Set secondrng = preQSRsheet.Range("o1:o" & LastRow)
secondarray = secondrng


LastRow = PostQSRsheet.Range("j" & Rows.Count).End(xlUp).Row
Set thirdrng = PostQSRsheet.Range("j1:j" & LastRow)
thirdarray = thirdrng


LastRow = PostQSRsheet.Range("o" & Rows.Count).End(xlUp).Row
Set fourthrng = PostQSRsheet.Range("o1:o" & LastRow)
fourtharray = fourthrng




For x = PreQueryID_row To UBound(firstArray)


       For y = PostQueryID_row To UBound(thirdarray)
            
            If firstArray(x, 1) = thirdarray(y, 1) Then
            
                  If secondarray(x, 1) = fourtharray(y, 1) Then
                  
                  ElseIf secondarray(x, 1) = "Open" And fourtharray(y, 1) = "Closed" Then
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Open in pre and closed in post"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
            
                  ElseIf secondarray(x, 1) = "Closed" And fourtharray(y, 1) = "Open" Then
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("d" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Open in pre and closed in post"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
                  
                  Else
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("d" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Open in pre and closed in post"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
                  
                  End If
            End If
        Next
Next






End Sub

 

[eleehl]

Sorry, pasted the wrong code...the correct code is below:

Sub Array_Compare_QSR()


Dim strFileToOpen1 As String, strFileToOpen2 As String
Dim preQSR_WB As Workbook, postQSR_WB As Workbook
Dim preQSRsheet As Worksheet, PostQSRsheet As Worksheet
Dim PostQSRsheet2 As Worksheet
Dim PreQueryID As Range, PostQueryID As Range
Dim PreQueryID_row As Long, PostQueryID_row As Long, PreQueryStatus_row As Long, PostQueryStatus_row As Long
Dim firstrng As Range, secondrng As Range, thirdrng As Range, fourthrng As Range
Dim rng1 As Range, rng2 As Range
Dim LastRow As Long, lngCNT As Long
Dim var1 As Variant, var2 As Variant, x
Dim firstArray As Variant, secondarray As Variant, thirdarray As Variant, fourtharray As Variant, y
Dim SearchRange1 As Range, SearchRange2 As Range
Dim count1 As Integer, count2 As Integer, count3 As Integer
Dim response




response = MsgBox("Please choose the pre-QSR file", vbOKCancel)
If response = vbCancel Then
Exit Sub
End If




'Open the file dialog
strFileToOpen1 = Application.GetOpenFilename(Title:="Please choose the pre-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


'Checking if file is selected


If strFileToOpen1 = "" Then
     MsgBox "No files selected.", vbExclamation, "Sorry!"
     'And exiting from the procedure
     Exit Sub
       
Else


    response = MsgBox("Please choose the post-QSR file", vbOKCancel)
    If response = vbCancel Then
    Exit Sub
    End If
    
    strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


If strFileToOpen2 = strFileToOpen1 Then
    MsgBox "The post-QSR file you have selected have the same filename as the pre-QSR file.", vbExclamation, "Please choose again"
    strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


ElseIf strFileToOpen2 = "" Then


    MsgBox "No files selected.", vbExclamation, "Sorry!"
    'And exiting from the procedure
Exit Sub


Else


'Opening the file if selected in the above step
Workbooks.Open Filename:=strFileToOpen1
Workbooks.Open Filename:=strFileToOpen2


'Assign variable to opened worksheets
Set preQSR_WB = Workbooks.Open(Filename:=strFileToOpen1)
Set postQSR_WB = Workbooks.Open(Filename:=strFileToOpen2)
Set preQSRsheet = preQSR_WB.Sheets("Sheet1")
Set PostQSRsheet = postQSR_WB.Sheets("Sheet1")
postQSR_WB.Worksheets.Add.Name = "Report"
postQSR_WB.Worksheets("Report").Move After:=Sheets(ActiveWorkbook.Sheets.Count)
Set PostQSRsheet2 = postQSR_WB.Sheets("Report")
End If
End If


Set PreQueryID_find = preQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")
Set PostQueryID_find = postQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")


Set PreQueryStatus_find = preQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")
Set PostQueryStatus_find = postQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")


PreQueryID_row = PreQueryID_find.Row
PostQueryID_row = PostQueryID_find.Row
PreQueryStatus_row = PreQueryStatus_find.Row
PostQueryStatus_row = PostQueryStatus_find.Row


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


PostQSRsheet2.Range("A1:E1").Value = Array("Query in Pre but not in Post", "Query In Post but Not in Pre", "Query ID", "Pre-QSR Query Status", "Post-QSR Status")


'sheet1 range and fill array
With preQSRsheet
        LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        
        Set rng1 = preQSRsheet.Range("J1:J" & LastRow)
        
        var1 = rng1


End With


'sheet2 range and fill array
With PostQSRsheet


        LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        
        Set rng2 = PostQSRsheet.Range("J1:J" & LastRow)
        var2 = rng2
End With


'check preQSR against postQSR
On Error GoTo NoMatch1
For lngCNT = PreQueryID_row To UBound(var1)
x = Application.WorksheetFunction.Match(var1(lngCNT, 1), rng2, False)
 'MsgBox x
 'Exit Sub
 Next
 
  'check postQSR against preQSR
  On Error GoTo NoMatch2
 For lngCNT = PostQueryID_row To UBound(var2)
 x = Application.WorksheetFunction.Match(var2(lngCNT, 1), rng1, False)
 'MsgBox x
 'Exit Sub
 Next
 
'checks query status column to see if queries have changed between pre and post migration
'results are posted on postmigration report under tab - 'Report' and also highlighted on both pre and post report


LastRow = preQSRsheet.Range("j" & Rows.Count).End(xlUp).Row
Set firstrng = preQSRsheet.Range("j1:j" & LastRow)
firstArray = firstrng


LastRow = preQSRsheet.Range("o" & Rows.Count).End(xlUp).Row
Set secondrng = preQSRsheet.Range("o1:o" & LastRow)
secondarray = secondrng


LastRow = PostQSRsheet.Range("j" & Rows.Count).End(xlUp).Row
Set thirdrng = PostQSRsheet.Range("j1:j" & LastRow)
thirdarray = thirdrng


LastRow = PostQSRsheet.Range("o" & Rows.Count).End(xlUp).Row
Set fourthrng = PostQSRsheet.Range("o1:o" & LastRow)
fourtharray = fourthrng




For x = PreQueryID_row To UBound(firstArray)


       For y = PostQueryID_row To UBound(thirdarray)
            
            If firstArray(x, 1) = thirdarray(y, 1) Then
            
                  If secondarray(x, 1) = fourtharray(y, 1) Then
                  
                  ElseIf secondarray(x, 1) = "Open" And fourtharray(y, 1) = "Closed" Then
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("d" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Open in pre and closed in post"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
            
                  ElseIf secondarray(x, 1) = "Closed" And fourtharray(y, 1) = "Open" Then
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("d" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Open in pre and closed in post"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
                  
                  Else
                  PostQSRsheet2.Range("c" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = firstArray(x, 1)
                  PostQSRsheet2.Range("d" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = secondarray(x, 1)
                  PostQSRsheet2.Range("e" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = fourtharray(y, 1)
                  fourthrng(y, 1).Interior.ColorIndex = 6
                  fourthrng(y, 6).Value = "Query Status has changed please check"
                  fourthrng(y, 6).Interior.ColorIndex = 6
                  secondrng(x, 1).Interior.ColorIndex = 6
                  
                  End If
            End If
        Next
Next
 


On Error GoTo 0


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
PostQSRsheet2.Columns.AutoFit
PostQSRsheet2.Activate
MsgBox ("Comparison is now complete" & vbCrLf & vbCrLf & "Please review the 'Reports' tab in the Post-QSR Report")


Exit Sub
      
NoMatch1:


PostQSRsheet2.Range("A" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = var1(lngCNT, 1)
Resume Next


NoMatch2:


PostQSRsheet2.Range("B" & PostQSRsheet2.Rows.Count).End(xlUp).Offset(1) = var2(lngCNT, 1)
Resume Next








End Sub

 

[RickXL]

... 20K rows takes about 45 sec.

One of the biggest time wasters is to keep reading worksheet data into VBA and vice versa. VBA and the Excel worksheet were written by different people at different times. The process for transferring data is not optimal. The trick is to do all your processing in one or the other.

Consequently, if I use VBA, I try and copy all the data into VBA in as few instructions as possible. You can read 100,000 rows in one instruction. Similarly, you can write 100,000, and more, rows with one instruction. Then you can rely on For/Next loops in VBA which are much faster than you might guess.

Dictionaries are like Collections but you have better access to the keys which makes them a lot more useful. Keys are forced to be unique so any problem involving duplicates makes me turn to Dictionaries. Also, because you have direct access to a Dictionary Item via the Key it makes them a VBA equivalent to the worksheet VLOOKUP instruction. The unique Key feature means that instructions like COUNTIF can also be easily implemented.


Regards,

 

[eleehl]

Rick, thanks for sharing this knowledge with me. I'm learning so much just by writing this macro! I'm trying to rewrite my code to be more efficient by incorporating what you have provided! Thanks for all the help!

One of the biggest time wasters is to keep reading worksheet data into VBA and vice versa. VBA and the Excel worksheet were written by different people at different times. The process for transferring data is not optimal. The trick is to do all your processing in one or the other.

Consequently, if I use VBA, I try and copy all the data into VBA in as few instructions as possible. You can read 100,000 rows in one instruction. Similarly, you can write 100,000, and more, rows with one instruction. Then you can rely on For/Next loops in VBA which are much faster than you might guess.

Dictionaries are like Collections but you have better access to the keys which makes them a lot more useful. Keys are forced to be unique so any problem involving duplicates makes me turn to Dictionaries. Also, because you have direct access to a Dictionary Item via the Key it makes them a VBA equivalent to the worksheet VLOOKUP instruction. The unique Key feature means that instructions like COUNTIF can also be easily implemented.


Regards,

 

[eleehl]

HI Rick,

What does this line ReDim out1(1 To UBound(ary1), 1 To 1) actually do?

Thanks,
Eric

Hi and welcome to the MrExcel Message Board.

If it were me, and if you are using Windows then I would probably use a Dictionary Object. Dictionaries are a bit like a two column array. The first column contains a key and the second can be anything. So, in this case, I would load it with all the keys and all the values in the column you want to monitor for changes.

The easiest and quickest way to get a lot of data from the worksheet into VBA is to use a Variant as an array. Then it is possible to load the Dictionary from that array very quickly with a For/Next loop.

The code below does that for both worksheets.

Then it loops over the data in column 4 of one sheet and compares it with the data in the Dictionary for the other worksheet. It notes the differences in another Varant/Array called out1. It creates out2 for the other sheet similarly.

Finally, it outputs out1 and out2 into column 5 of the original sheets. They will now contain comments like: Same, Changed and Missing. "Missing" is when the key is not found in the other worksheet.

Sub Compare()
    Dim ary1    As Variant
    Dim ary2    As Variant
    Dim out1    As Variant
    Dim out2    As Variant
    Dim dic1    As Object
    Dim dic2    As Object
    Dim i       As Long
    
    With ThisWorkbook.Worksheets("Pre-Report")
        ary1 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
        Set dic1 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ary1)
            dic1(ary1(i, 1)) = ary1(i, 4)
        Next
    End With
    
    With ThisWorkbook.Worksheets("Post-Report")
        ary2 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
        Set dic2 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ary2)
            dic2(ary2(i, 1)) = ary2(i, 4)
        Next
    End With
    
    ReDim out1(1 To UBound(ary1), 1 To 1)
    For i = 1 To UBound(ary1)
        If dic2.exists(ary1(i, 1)) Then
            If dic2(ary1(i, 1)) = ary1(i, 4) Then out1(i, 1) = "Same" Else out1(i, 1) = "Changed"
        Else
            out1(i, 1) = "Missing"
        End If
    Next
    
    ReDim out2(1 To UBound(ary2), 1 To 1)
    For i = 1 To UBound(ary2)
        If dic1.exists(ary2(i, 1)) Then
            If dic1(ary2(i, 1)) = ary2(i, 4) Then out2(i, 1) = "Same" Else out2(i, 1) = "Changed"
        Else
            out2(i, 1) = "Missing"
        End If
    Next
    
    With ThisWorkbook.Worksheets("Pre-Report")
        .Range("E2").Resize(UBound(out1)) = out1
    End With
    
    With ThisWorkbook.Worksheets("Post-Report")
        .Range("E2").Resize(UBound(out2)) = out2
    End With
End Sub

Regards,

 

[eleehl]

HI Rick,

I have converted fully to your code which is working great even for large files.

I ran into a problem though. Because I"m working with *.xls sheet1 gets capped at around 65,000 lines. The report generated puts any rows beyond the sheet1 threshold to the next sheet. How do I detect whether there are multiple sheets that need to be compared at the start of the macro? If so, be able to continue the comparison on the next page or pages for that matter?

Sub Dict_Compare_QSR()


Dim strFileToOpen1 As String, strFileToOpen2 As String
Dim preQSR_WB As Workbook, postQSR_WB As Workbook
Dim preQSRsheet As Worksheet, PostQSRsheet As Worksheet
Dim PostQSRsheet2 As Worksheet
Dim PreQueryID As Range, PostQueryID As Range
Dim PreQueryID_row As Long, PostQueryID_row As Long, PreQueryStatus_row As Long, PostQueryStatus_row As Long
Dim rng1 As Range, rng2 As Range
Dim LastRow As Long, lngCNT As Long
Dim response
Dim StartTime As Double
Dim MinutesElapsed As String
Dim SecondsElapsed As Double
Dim ary1    As Variant
Dim ary2    As Variant
Dim out1    As Variant
Dim out2    As Variant
Dim dic1    As Object
Dim dic2    As Object
  






response = MsgBox("Please choose the pre-QSR file", vbOKCancel)
If response = vbCancel Then
Exit Sub
End If




'Open the file dialog
strFileToOpen1 = Application.GetOpenFilename(Title:="Please choose the pre-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


'Checking if file is selected


If strFileToOpen1 = "" Then
     MsgBox "No files selected.", vbExclamation, "Sorry!"
     'And exiting from the procedure
     Exit Sub
       
Else


    response = MsgBox("Please choose the post-QSR file", vbOKCancel)
    If response = vbCancel Then
    Exit Sub
    End If
    
    strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


If strFileToOpen2 = strFileToOpen1 Then
    MsgBox "The post-QSR file you have selected have the same filename as the pre-QSR file.", vbExclamation, "Please choose again"
    strFileToOpen2 = Application.GetOpenFilename(Title:="Please choose the post-QSR file to open", filefilter:="Excel Files *.xls* (*.xls*),")


ElseIf strFileToOpen2 = "" Then


    MsgBox "No files selected.", vbExclamation, "Sorry!"
    'And exiting from the procedure
Exit Sub


Else






'Opening the file if selected in the above step
Workbooks.Open Filename:=strFileToOpen1
Workbooks.Open Filename:=strFileToOpen2


'Assign variable to opened worksheets
Set preQSR_WB = Workbooks.Open(Filename:=strFileToOpen1)
Set postQSR_WB = Workbooks.Open(Filename:=strFileToOpen2)
Set preQSRsheet = preQSR_WB.Sheets("Sheet1")
Set PostQSRsheet = postQSR_WB.Sheets("Sheet1")
'postQSR_WB.Worksheets.Add.Name = "Report"
'postQSR_WB.Worksheets("Report").Move After:=Sheets(ActiveWorkbook.Sheets.Count)
'Set PostQSRsheet2 = postQSR_WB.Sheets("Report")
End If
End If


Set PreQueryID_find = preQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")
Set PostQueryID_find = postQSR_WB.Worksheets("Sheet1").Range("j1:j10000").Find(what:="Query ID")


Set PreQueryStatus_find = preQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")
Set PostQueryStatus_find = postQSR_WB.Worksheets("Sheet1").Range("o1:j10000").Find(what:="Query Status")


PreQueryID_row = PreQueryID_find.Row
PostQueryID_row = PostQueryID_find.Row
PreQueryStatus_row = PreQueryStatus_find.Row
PostQueryStatus_row = PostQueryStatus_find.Row


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


'PostQSRsheet2.Range("A1:E1").Value = Array("Query in Pre but not in Post", "Query In Post but Not in Pre", "Query ID", "Pre-QSR Query Status", "Post-QSR Status")




StartTime = Timer






    
    Dim i       As Long
    
    With preQSRsheet
        ary1 = .Range("j2", .Cells(.Rows.Count, "j").End(xlUp)).Resize(, 6)
        
        Set dic1 = CreateObject("Scripting.Dictionary")
                
        For i = PreQueryID_row To UBound(ary1)
            dic1(ary1(i, 1)) = ary1(i, 6)
            
        Next
    End With
    
    With PostQSRsheet
        ary2 = .Range("j2", .Cells(.Rows.Count, "j").End(xlUp)).Resize(, 6)
        Set dic2 = CreateObject("Scripting.Dictionary")
        
        
        For i = PreQueryID_row To UBound(ary2)
            dic2(ary2(i, 1)) = ary2(i, 6)
            
        Next
    End With
    
    ReDim out1(1 To UBound(ary1), 1 To 2)
    For i = PreQueryID_row To UBound(ary1)
        If dic2.exists(ary1(i, 1)) Then
            If dic2(ary1(i, 1)) = ary1(i, 6) Then out1(i, 1) = "Same" Else out1(i, 1) = "Query Status Changed"
        Else
            out1(i, 1) = "Deleted in Post-Migration"
        End If
    Next
    
    ReDim out2(1 To UBound(ary2), 1 To 2)
    For i = PreQueryID_row To UBound(ary2)
        If dic1.exists(ary2(i, 1)) Then
            If dic1(ary2(i, 1)) = ary2(i, 6) Then out2(i, 1) = "Same" Else out2(i, 1) = "Query Status Changed"
        Else
            out2(i, 1) = "New Query in Post-Migration"
        End If
    Next
    
    With preQSR_WB.Sheets("Sheet1")
        .Range("T2").Resize(UBound(out1)) = out1
    End With
    
    With postQSR_WB.Sheets("Sheet1")
        .Range("T2").Resize(UBound(out2)) = out2
    End With
    
SecondsElapsed = Round(Timer - StartTime, 2)
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " Minutes", vbInformation












End Sub

 

[RickXL]

What does this line ReDim out1(1 To UBound(ary1), 1 To 1) actually do?

The loop that follows that line populates the array called: out1. So, before that, we have to say exactly how big the array will need to be.

Fortunately, we do know how big the array needs to be. It will need to have one row for each row in the input array called ary1. It will also need only one column. We also know that the array, ary1, starts at 1 and extends to an upper bound. We can find that upper bound by using the UBound function. That is where the Ubound(ary1) comes from.

Excel likes to make things difficult so it has different rules about which arrays start from 0 and which ones start from 1. You can use the statement: Option Base 1 (or Option Base 0) to specify SOME of the default options but not all. Consequently, it is always safest to specify both the start and end indexes for any array.

If we had known that the array would be a 10 x 1 array at the outset we could have said:

Dim out1(1 to 10, 1 to 1)

We did not know how many rows would be required until we read in the ary1 data. So we had to use a later ReDim, instead of Dim. Hence:

ReDim out1(1 To UBound(ary1), 1 To 1)

I hope that makes sense.

I find that if array sizes can change depending on the data then it is best to base all your array extents and loop sizes on either the .Count property of an object or the UBound property of an array. That way, you do not need to make any changes if the data changes.

(By the way, UBound(ary1) is the same as UBound(ary1, 1). The second "1" means the first array dimension. UBound(ary1, 2) means the upper bound of the second dimension.)


Regards,

 

[RickXL]

I ran into a problem though. Because I"m working with *.xls sheet1 gets capped at around 65,000 lines. The report generated puts any rows beyond the sheet1 threshold to the next sheet. How do I detect whether there are multiple sheets that need to be compared at the start of the macro? If so, be able to continue the comparison on the next page or pages for that matter?

My first choice would be to remove the 65536 limit.

What version of Excel are you using? Is it really pre-2007 or is it running in Compatibility Mode?