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

 

[offthelip]

Your slow code is because you are accessing the worksheet multiple times in a double loop, you have successfully loaded the input data into array but you are still writing to the worksheet many many times. the way around this is to copy the data to an output array ( outarr) and then write the array back to the workhseet at the end. Try this code instead of your double loop ( untested) :

lastrow = UBound(toolary)
outarr = Worksheets("Compare Tool").Range("X27:AF" & lastrow)
   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)
                        outarr(r, 2) = Data_ary(x, 38)
                        outarr(r, 3) = Data_ary(x, 39)
                        outarr(r, 4) = Data_ary(x, 40)
                        outarr(r, 5) = Data_ary(x, 41)
                        outarr(r, 7) = Data_ary(x, 42)
                        outarr(r, 8) = Data_ary(x, 43)
                            If Data_ary(x, 44) <> "" Then
                                outarr(r, 9) = Data_ary(x, 44)
                                outarr(r, 10) = Data_ary(x, 45)
                            End If
                    End If
                Next x
        End If
   Next r
Worksheets("Compare Tool").Range("X27:AF" & lastrow) = outarr

Note there are NO accesses to the worksheet in the loop so it should be very very fast

 

[jewkes6000]

@offthelip - This code did work (just had to change X27 to X28); however, at the end when it copies all of the data back into "outarr", it overwrites rows which don't meet the criteria. In other words, the line of code

If toolary(r, 5) = "Single" Or toolary(r, 5) = "T2 Head" Then

is telling it to only look at these rows. When the final line of code copies back to "outarr", it is copying from X28:AF. The problem with this is that I have several formulas subtotaling different sections of the worksheets. So this is overwriting all of those formulas with blank cells. Is there a way around this?

 

[jewkes6000]

@offthelip - Just thinking outload here, but if I created named ranges for all of the rows which need to be skipped (about 50), could I somehow let it know to skip these 50 rows/ranges? Seems tedious, but it'd probably still be much faster than my original solution.

 

[offthelip]

When you have Data and formula mixed up it inevitably makes writing VBA much more difficult, when I am designing workbooks I do try to keep the data and formula separate so that breaking out into VBA is much easier. There are two ways round this, Firstly if you can define the ranges where there is data you can treat each range separately leaving the formula untouched. The code will very similar to above. This will slow it down slightly because you will be writing to the worksheet a number of times. Secondly the alternative which is faster and I would do if possible is to write the equations back in as you write the data. i.e just add the equations into the correct element in the outarr array. This will be super fast. but it does depend on what the equations are and if you ever change them

 

[jewkes6000]

@offthelip - I have tried to put formulas into the outarr, but rather than writing them in, I would like to copy them from some columns to the right. Essentially, columns X through AI are the same formulas as AK through AV. If I'm working in Excel, I can just copy the cells and paste them and Excel automatically changes the references. Is there a way to do this in VBA? I've already come up with the if statement to identify the rows which need formulas, but in the code below, when I assign the cells from AK through AV (37 through 48), it's only assigning the values (which are zero). I'm including the entire loop code, but I'm just referring to the last part. I would prefer to use this "copy/paste" method (if that's what you call it) from the columns to the right because the formula references are not the same throught these "subtotal rows". So if I simply write the formulas in the array, then I would have to do separate formulas for 50 different rows to ensure the references are correct.

    lastrow = UBound(Toolary)
    outarr = Worksheets("Compare Tool").Range("X28:AI" & lastrow)

    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)
                         outarr(r, 2) = Data_ary(x, 38)
                         outarr(r, 3) = Data_ary(x, 39)
                         outarr(r, 4) = Data_ary(x, 40)
                         outarr(r, 5) = Data_ary(x, 41)
                         outarr(r, 6) = Data_ary(x, 42)
                         outarr(r, 7) = Data_ary(x, 43)
                             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
         End If
         'The following will put the formulas into the subtotals lines (they get overwritten without this code)
         If Toolary(r, 5) = "T0 Sub" Or Toolary(r, 5) = "T0.5 Sub" Or Toolary(r, 5) = "T1 Sub" Or Toolary(r, 5) = "T2 Sub" Then
            outarr(r, 1) = Toolary(r, 37)
            outarr(r, 2) = Toolary(r, 38)
            outarr(r, 3) = Toolary(r, 39)
            outarr(r, 4) = Toolary(r, 40)
            outarr(r, 5) = Toolary(r, 41)
            outarr(r, 6) = Toolary(r, 42)
            outarr(r, 7) = Toolary(r, 43)
            outarr(r, 11) = Toolary(x, 47)
            outarr(r, 12) = Toolary(x, 48)
         End If
    Next r
    Worksheets("Compare Tool").Range("X28:AF" & lastrow) = outarr

 

[offthelip]

Unfortunately it is not not that easy!! To pick up the formula when you load an array from the worksheet you need to load it into a separate array from the values using code like this:

With Sheets("Compare Tool")
        Toolary = .Range("A28:DV" & .Range("U" & Rows.Count).End(xlUp).Row).Value2
        Toolfrom = .Range("A28:DV" & .Range("U" & Rows.Count).End(xlUp).Row).Formula
    End With
End Sub

This will load the formula instead of the values in array Toolfrom.
However this doesn't solve you problem because the values held in toolfrom are just text values, and so if you write the values into a column to the left EXCEL won't change the references automatically as happens when you copy and paste, instead you get EXACTLY the same equation. Unfortunately copying and pasting the the formula using reference to the cells will be slow again because you are referencing the worksheet multiple times.
I notice that you appear to be putting in formula to subtotal the numbers if this is the case it is very easy to put the formula in using vba see this thread:
average and StdDev on dynamic range

 

[offthelip]

I have thought of a quick and easy way of solving your problem, if you load all the formula into an array and then detect which cells have formula and copy them to the output array like this: change these two lines:

lastrow = UBound(Toolary)
 outarr = Worksheets("Compare Tool").Range("X28:AI" & lastrow)

to

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)
 If Left(toolfrom(i, j), 1) = "=" Then
  outarr(i, j) = toolfrom(i, j)
 End If
 Next j
 Next i

 

[jewkes6000]

*** Sorry, I did not see your previous reply before writing this. I will now look at your previous reply ***
I've used the following code which hinds the header row so that I can make this thing dynamic and not have to enter the formula 50 times. However, the line of code where I input the formula is not writing to the Toolary. When I look in the "Locals" window, it still says empty after running this.

         If Toolary(r, 5) = "T0 Sub" Or Toolary(r, 5) = "T0.5 Sub" Or Toolary(r, 5) = "T1 Sub" Or Toolary(r, 5) = "T2 Sub" Then
            FindHeader = Sheets("Compare Tool").Range("E:E").Find(What:="T2 Head", After:=Cells(r + 28, 5), SearchDirection:=xlPrevious).Row
            Cells(r, 24).formula = "=Subtotal(9,X" & FindHeader & ":X" & r + 27 & ")"

 

[jewkes6000]

I tried running your code and it errors out with "Run-time error '9': Subscript out of range". It is erroring out on the "If Left(toolfrom(i, j), 1) = "=" Then " line and it's at i=1 and j=10 of the loop. If I'm looking at it correctly, i=1 and j=10 is cell AG28 which is blank. In fact, all of row 28 is blank. So I'm not sure why it would run through columns X through AF, but then error on AG?