Loop Through Column & Match Data Using Arrarys

[jewkes6000]

To import data from multiple projects and view in a side-by-side manner, I had a macro which was looping through data on two sheets, finding data which matched some criteria, and then copying that data into specified rows and columns. The code I came up simply looped through the data on both sheets and it worked; however, it took about 30 seconds per project to import. With 8 projects, it could take anywhere from 4 to 5 minutes to complete. While this isn't too painful, it was suggested that I use arrays as they are MUCH MUCH faster. Below is my best attempt to use arrarys; however, it took even longer than my original method and I was only trying to import one project. Can anyone let me know what I can do to speed up this macro? Below is the code I've tried to use with arrays. I've also included a link to actual file. In the file, you can also view my old macro titled "Sub Compare_Projects_NoArrarys ()".

Looping with Arrarys Still Taking Too Long.xlsm

drive.google.com

Sub Compare_Projects()

Dim Toolary As Variant, Data_ary As Variant, PrjTitle_ary As Variant, CurrentAry As Variant
   Dim r As Long, nr As Long, x As Long, c As Long, CurrentCostCod As Long
   Dim Cl As Range
   Dim Project1 As String, Project2 As String, Project3 As String, Project4 As String, Project5 As String, Project6 As String, Project7 As String, Project8 As String

Application.ScreenUpdating = False

    With Sheets("Setup Page")
        Typology = .Range("L18")
        Project1 = .Range("U11").Value
        Project2 = .Range("U12").Value
        Project3 = .Range("U13").Value
        Project4 = .Range("U14").Value
        Project5 = .Range("U15").Value
        Project6 = .Range("U16").Value
        Project7 = .Range("U17").Value
        Project8 = .Range("U18").Value
    End With
      
   'Put data into the arrarys (Toolary & Data_ary)
    Data_ary = Sheets("Cost Data").Range("A1").CurrentRegion.Value2
    
    With Sheets("Compare Tool")
        Toolary = .Range("A28:DV" & .Range("U" & Rows.Count).End(xlUp).Row).Value2
    End With
          
'Project 1
    'Check if Project field is blank
    Sheets("Setup Page").Select
    If Range("U11") = "" Then GoTo Project2
    
    With Sheets("Cost Data")
        FirstRowDB = .Range("A:A").Find(What:=Project1, searchdirection:=xlNext).Row 'xlNext starts from top
        GSFPrj = .Cells(FirstRowDB, 13)
        GSFTypology = .Cells(FirstRowDB, 18)
    End With
    
     'Copy the GSF area & Total Project cost and paste into the top of the "Compare Tool" tab
    Sheets("Prj Info").Select
    FindPrj = Application.Match(Project1, Range("A:A"), 0)
    Total_Prj_Cost = Sheets("Prj Info").Cells(FindPrj, 16)
    Sheets("Compare Tool").Range("AD19") = GSFTypology
    Sheets("Compare Tool").Range("AD16") = GSFPrj
    Sheets("Compare Tool").Range("AD15") = Total_Prj_Cost
  
   For r = 1 To UBound(Toolary)
        If Toolary(r, 5) = "Single" Or Toolary(r, 5) = "T2 Head" Then
            CurrentCostCode = Toolary(r, 21)
            CurrentT0 = Toolary(r, 9)
                For x = 2 To UBound(Data_ary)
                    If Data_ary(x, 1) = Project1 And Data_ary(x, 34) = CurrentCostCode And Data_ary(x, 22) = CurrentT0 And Data_ary(x, 17) = Typology Then
                        Sheets("Compare Tool").Range("X" & r + 27).Value = Data_ary(x, 37)
                        Sheets("Compare Tool").Range("Y" & r + 27).Value = Data_ary(x, 38)
                        Sheets("Compare Tool").Range("Z" & r + 27).Value = Data_ary(x, 39)
                        Sheets("Compare Tool").Range("AA" & r + 27).Value = Data_ary(x, 40)
                        Sheets("Compare Tool").Range("AB" & r + 27).Value = Data_ary(x, 41)
                        Sheets("Compare Tool").Range("AC" & r + 27).Value = Data_ary(x, 42)
                        Sheets("Compare Tool").Range("AD" & r + 27).Value = Data_ary(x, 43)
                            If Data_ary(x, 44) <> "" Then
                                Sheets("Compare Tool").Range("AE" & r + 27).Value = Data_ary(x, 44)
                                Sheets("Compare Tool").Range("AF" & r + 27).Value = Data_ary(x, 45)
                            End If
                    End If
                Next x
        End If
   Next r
  
'Project 2
Project2:


Application.ScreenUpdating = True
End Sub

 

[jewkes6000]

In looking at the above image..... why is the "toolfrom" arrary only going from 1 to 9 on the columns? X to AF should be 1 to 12. Maybe this is the causing the error when it get to number 10?

Update.... Duh, I found my mistake. I changed the range from AI to AF on the outarr, but not on the toolfrom array.

 

[jewkes6000]

@offthelip - I have another question (and I pray that it's the last). Everything worked great in terms of copying the formulas over for the subtotals. But I have another problem because on my "Cost Data" tab, there are instances where I have two lines of data which need to be combined into one. What is happening is when there is a second line of data on the Cost Data tab which meets all of the criteria, it's simply overwriting it to the outarr array rather than adding it. Is there a way to add the data to the array rather than replace it?

For r = 1 To lastrow
         If Toolary(r, 5) = "Single" Or Toolary(r, 5) = "T2 Head" Then
            CurrentCostCode = Toolary(r, 21)
            CurrentT0 = Toolary(r, 9)
                 For x = 2 To UBound(Data_ary)
                     If Data_ary(x, 1) = Project1 And Data_ary(x, 34) = CurrentCostCode And Data_ary(x, 22) = CurrentT0 And Data_ary(x, 17) = Typology Then
                         outarr(r, 1) = Data_ary(x, 37) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 2) = Data_ary(x, 38) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 3) = Data_ary(x, 39) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 4) = Data_ary(x, 40) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 5) = Data_ary(x, 41) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 6) = Data_ary(x, 42) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                         outarr(r, 7) = Data_ary(x, 43) [COLOR=rgb(226, 80, 65)]'This is where the data is getting overwritten[/COLOR]
                             If Data_ary(x, 44) <> "" Then
                                 outarr(r, 8) = Data_ary(x, 44)
                                 outarr(r, 9) = Data_ary(x, 45)
                             End If
                     End If
                 Next x

 

[offthelip]

The way round that is to set all the values in outarr to zero to start with and then ALWAYS add the data_ary value in. If you modify the formula copy bit like this:

lastrow = UBound(toolary)
outarr = Worksheets("Compare Tool").Range("X28:AF" & lastrow)
With Sheets("Compare Tool")
        toolfrom = .Range("X28:AF" & lastrow).Formula
End With
For i = 1 To UBound(outarr, 1)
For j = 1 To UBound(outarr, 2)
outarr(i, j) = 0                                  ' Note I have added this line
If Left(toolfrom(i, j), 1) = "=" Then
  outarr(i, j) = toolfrom(i, j)
End If
Next j
Next i

and then modify the code where it is overwriting the data like this example:

                     If Data_ary(x, 1) = Project1 And Data_ary(x, 34) = CurrentCostCode And Data_ary(x, 22) = CurrentT0 And Data_ary(x, 17) = Typology Then
                         outarr(r, 1) =outarr(r, 1)+ Data_ary(x, 37) 'This is where the data is getting overwritten

 

[jewkes6000]

@offthelip - Thank you so much. It's working great. I do have one question though... What is the purpose of setting outarr to zero? With the line of code "outarr(i,j) = 0", it does import everything correctly; however, it messes with the formatting, everything is showing zeros rather than blanks, and it looks very messy. I removed this line of code and everything still worked, but it didn't mess up the formatting. So if I remove that line of code, will everything be okay? It seems to work perfect without it. Here is the updated code which seems to work perfect:

    lastrow = UBound(Toolary)
    outarr = Worksheets("Compare Tool").Range("X28:AI" & lastrow)
    
    'The following will put the formulas from the subtotals lines into the "toolfrom" array and then put it into the "outarr" array
    With Sheets("Compare Tool")
        toolfrom = .Range("X28:AI" & lastrow).formula
    End With
    For i = 1 To UBound(outarr, 1)
    For j = 1 To UBound(outarr, 2)
    'outarr(i, j) = 0 '''''This line seems to mess up formating, but the code appears to work without it
    If Left(toolfrom(i, j), 1) = "=" Then 'erroring out at i=1 and j=10
     outarr(i, j) = toolfrom(i, j)
    End If
    Next j
    Next i
  
    For r = 1 To lastrow
         If Toolary(r, 5) = "Single" Or Toolary(r, 5) = "T2 Head" Then
            CurrentCostCode = Toolary(r, 21)
            CurrentT0 = Toolary(r, 9)
                 For x = 2 To UBound(Data_ary)
                     If Data_ary(x, 1) = Project1 And Data_ary(x, 34) = CurrentCostCode And Data_ary(x, 22) = CurrentT0 And Data_ary(x, 17) = Typology Then
                         outarr(r, 1) = outarr(r, 1) + Data_ary(x, 37)
                         outarr(r, 2) = outarr(r, 2) + Data_ary(x, 38)
                         outarr(r, 3) = outarr(r, 3) + Data_ary(x, 39)
                         outarr(r, 4) = outarr(r, 4) + Data_ary(x, 40)
                         outarr(r, 5) = outarr(r, 5) + Data_ary(x, 41)
                         outarr(r, 6) = outarr(r, 6) + Data_ary(x, 42)
                         outarr(r, 7) = outarr(r, 7) + Data_ary(x, 43)
                             If Data_ary(x, 44) <> "" Then
                                 outarr(r, 8) = outarr(r, 8) + Data_ary(x, 44)
                                 outarr(r, 9) = Data_ary(x, 45) 'Do not add this because this cell is text, not a number
                             End If
                     End If
                 Next x
         End If
    Next r
    Worksheets("Compare Tool").Range("X28:AF" & lastrow) = outarr

 

[offthelip]

The reason for setting outarr to zero was because if there were existing numbers in the cells before you run the macro then the data_ary values would be added to them, if this is what you want then fine . It was my understanding if one line trigger you wanted the value copied which would overwrite any existing number if it triggered again it would add to it. if this is what you want, what you could do at the end is run though outarr again and change any zero to a blank and then the formatting would be ok.

 

[jewkes6000]

@offthelip - Thank you so much for your help and especially sticking with me to the end. At the very beginning of the macro, it clears all of the cells except the formulas. So that is why there were no issues with removing the line. Thank you again! The code truly is exponentially faster using arrays.

 

[offthelip]

Glad to be of help, Learning to use arrays is the easiest way of writing fast code, I very fairly do the other things like screenupdating etc, etc because using arrays for most tasks only take a few milliseconds.