Excel VBA-根据图纸上的单元格值从阵列中粘贴值

Question

Good afternoon everyone,

I am not sure if I can explain this properly. I have a macro that filters information by row from a single sheet and records only the necessary four columns into a 2D array. The resulting array is currently 96 rows and 4 columns, it can have more rows, but is limited to only four columns.

The code currently looks like this:

Dim my_array4() As Variant

Dim my_array3 As Variant
Dim i As Long, x As Long
Dim cnt As Long

cnt = ThisWorkbook.Worksheets("Cost Allocation").Evaluate("COUNTIFS(L4:L1060,""Actual"",J4:J1060,""<>"",D4:D1060,""<>"",G4:G1060,""<>0"")") + ThisWorkbook.Worksheets("Cost Allocation").Evaluate("COUNTIFS(L4:L1060,""Actual"",K4:K1060,""<>"",D4:D1060,""<>"",H4:H1060,""<>0"")")
If cnt > 0 Then
    ReDim my_array4(1 To cnt, 1 To 6) As Variant

    my_array3 = ThisWorkbook.Worksheets("Cost Allocation").Range("C5:O1060").Value
    x = 1
    For i = 1 To UBound(my_array3, 1)
        If my_array3(i, 10) = "Actual" And my_array3(i, 2) <> "" And my_array3(i, 5) <> 0 Then
            If my_array3(i, 6) <> 0 And my_array3(i, 9) <> "" Then
                my_array4(x, 1) = my_array3(i, 8)
                my_array4(x, 2) = my_array3(i, 2)
                my_array4(x, 3) = my_array3(i, 4)
                my_array4(x, 4) = my_array3(i, 5)
                x = x + 1
                my_array4(x, 1) = my_array3(i, 9)
                my_array4(x, 2) = my_array3(i, 2)
                my_array4(x, 3) = my_array3(i, 4)
                my_array4(x, 4) = my_array3(i, 6)
                x = x + 1
            Else
                my_array4(x, 1) = my_array3(i, 8)
                my_array4(x, 2) = my_array3(i, 2)
                my_array4(x, 3) = my_array3(i, 4)
                my_array4(x, 4) = my_array3(i, 5)
                x = x + 1
            End If
        End If
    Next i

    Sheets("Sheet1").Range("A1").Resize(UBound(my_array4, 1), 4) = my_array4
End If

As you can see, in the second last row of the code I am just pasting the whole thing on to Sheet1. This is just to make sure that the array is created properly. This part of the code will be deleted.

The array setup is as follows: column 1 - account code; column 2 - employee/vendor name; column 3 - invoice # or whatnot; column 4 - amount.

Now, I have an "Actual" sheet, which looks like this:

Here's my question: is it possible for the macro to go through the first column of "Actual" sheet and if the value (say, 0290) matches the account code in column 1 of the array, paste values from columns 2 and 4 (vendor name and amount) of the array into "Actual" sheet column 3 and 6 respectively? Then go to the next row of "Actual" and if there is another row in the array with the same account code, then paste it below, if not, then just continue on to the next row and so forth.

I would appreciate any help with this.

PS I know I could use INDEX/MATCH formula, but the Actual sheet has 7220 rows and using that formula will slow down the workbook.

Answer 1

Maybe this will work with a few tweaks.

 'Loop Actual sheet and update the rows
Dim wsActual As Worksheet
Set ws = ActiveWorkbook.Sheets("Actual")

Dim iRow As Integer
'You starting row in the actual sheet
iRow = 1
Dim iEndRow As Integer
'Set this.
iEndRow = 100

Dim aCompletedLookups() As String


'store the value from the actual sheet so we can test if it changed
Dim sLookupValue As String

'Store the Array location outside the loop so we can start at the last iteration if we need to
Dim iArrayRow As Integer

For iRow To iEndRow Step 1
    'lookup the value in the array and get the index if exist
    Dim foundMatch As Boolean
    foundMatch = False

    Dim iArrayStart As Integer
    iArrayStart = 0
    If sLookupValue = wsActual.Cells(iRow, 1).Value Then
        'This account code is the same as the previous so start the array loop at the last iteration.
        iArrayStart = iArrayRow + 1
        'if we have completed the array then there are no more records for this account.
        'Store this lookup value in an array so we can skip it next time it pops up.
        If iArrayStart > Ubound(my_array4) - 1 Then
            ReDim Preserve aCompletedLookups(Ubound(aCompletedLookups))
            aCompletedLookups(Ubound(aCompletedLookups) - 1) = sLookupValue
            'Continue tp the next iRow
            Goto NextIterationOfActual
        ElseIf
        'Check if this lookup value has exhausted the array already.
            Dim i As Integer
            For i = 0 To Ubound(aCompletedLookups) - 1 Step 1
                If sLookupValue = aCompletedLookups(i) Then
                    Goto NextIterationOfActual
                End If
            Next i
        End If      
    End If
    sLookupValue = wsActual.Cells(iRow, 1).Value

    For iArrayRow = iArrayStart To Ubound(my_array4) - 1 Step 1
        If my_array4(iArrayRow, 0) = sLookupValue Then
            foundMatch = True
            Exit For
        End If  
    Next iArrayRow

    If foundMatch Then
        'Update the Actual sheet
        wsActual.Cells(iRow, 3).Value = my_array4(iArrayRow, 2)
        wsActual.Cells(iRow, 6).Value = my_array4(iArrayRow, 4)
    End if
    NextIterationOfActual:  
Next iRow