Loop Through Column & Match Data Using Arrarys

jewkes6000

Board Regular
Joined
Mar 25, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
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 ()".



VBA Code:
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

Board Regular
Joined
Mar 25, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
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.
 

Some videos you may like

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

jewkes6000

Board Regular
Joined
Mar 25, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
@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?

VBA Code:
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,658
Office Version
  1. 2010
Platform
  1. Windows
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:
VBA Code:
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:
VBA Code:
                     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

Board Regular
Joined
Mar 25, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
@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:

VBA Code:
    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

Well-known Member
Joined
Dec 23, 2017
Messages
1,658
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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

Board Regular
Joined
Mar 25, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
@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

Well-known Member
Joined
Dec 23, 2017
Messages
1,658
Office Version
  1. 2010
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,991
Messages
5,599,242
Members
414,298
Latest member
bongielondy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top