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

eleehl · Jan 6, 2017

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

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

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

Rich (BB code):

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.

Rich (BB code):

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

eleehl · Jan 19, 2017

I'm running Office 2010 so in compatibility mode. However the third party program that generates the report only generates in .xls format. My current workaround is to have the files converted to XLSX first, manually. Then, I incorporated the code to count how many sheets there are - I only accounted for another extra sheet as I don't see a scenario where there would be more than 131,072 lines. So if I see more than 1 sheet, I copy whatever is in sheet2 onto the end of sheet1 and make the comparison that way. It's not ideal as it is not a one step process. If you have any ideas/solution on how I can do all of this with one click that would be great. Thanks

This is the code that I currently have:

Rich (BB code):

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 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
Dim StartTime As Double
Dim MinutesElapsed As String
Dim SecondsElapsed As Double
Dim PreSheetCount As Integer
Dim PostSheetCount As Integer






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")


PreSheetCount = preQSR_WB.Sheets.Count
PostSheetCount = postQSR_WB.Sheets.Count


End If
End If


Dim lastrow_find As Long
Dim lastrow_find2 As Long


Dim new_row As Long
Dim new_row2 As Long




lastrow_find = preQSR_WB.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow_find2 = postQSR_WB.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row


If PreSheetCount > 1 Then
preQSR_WB.Sheets("sheet2").UsedRange.SpecialCells(xlCellTypeVisible).Copy
new_row = lastrow_find + 1
preQSR_WB.Sheets("sheet1").Range("a" & new_row).PasteSpecial xlPasteValuesAndNumberFormats




postQSR_WB.Sheets("sheet2").UsedRange.SpecialCells(xlCellTypeVisible).Copy
new_row2 = lastrow_find2 + 1
postQSR_WB.Sheets("sheet1").Range("a" & new_row2).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Else
'do nothing
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


StartTime = Timer


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 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 said:
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?

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

eleehl

New Member

eleehl

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

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

eleehl

New Member

eleehl

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock