Lookup macro into new sheet

[Kristian]

I'm working on a macro where I can copy and paste values from one sheet (monthly) into another sheet (Profit&Loss). The monthly sheet will always look the same except sometime new items gets added. I already made it work but in limited way. Currently my macro takes one or several items from the monthly sheet adds them together and inserts them into my Profit&Loss sheet based on a 1-3 lookup functions. For instance, the item "Utilities" is a collection of "7430 - Utilities", "7480 - Refuse Collection" and "7540 - Telephone".
In the future I want to add more items to this collection without changing the VBA

This is what my macro currently looks like

Sub GetMonthlyData()

On Error Resume Next
Dim Tot_Row As Long
Dim Tot_Clm As Long

Table1 = Sheets("Profit&Loss").Range("A8:A59")
Table2 = Sheets("Monthly").Range("A7:G83")
Table3 = Sheets("Profit&Loss").Range("B8:B59")
Table4 = Sheets("Profit&Loss").Range("C8:C59")
Tot_Row = Sheets("Profit&Loss").Range("E8").Row
Tot_Clm = Sheets("Profit&Loss").Range("E8").Column

For Each c1 In Table1
    If IsEmpty(Cells(Tot_Row, 1)) = False Then
    Sheets("Profit&Loss").Cells(Tot_Row, Tot_Clm) = Application.WorksheetFunction.VLookup(c1, Table2, 7, False)
    End If
    If IsEmpty(Cells(Tot_Row, 2)) = False Then
    Sheets("Profit&Loss").Cells(Tot_Row, Tot_Clm) = Application.WorksheetFunction.VLookup(Cells(Tot_Row, 2), Table2, 7, False) + Application.WorksheetFunction.VLookup(c1, Table2, 7, False)
    End If
    If IsEmpty(Cells(Tot_Row, 3)) = False Then
    Sheets("Profit&Loss").Cells(Tot_Row, Tot_Clm) = Application.WorksheetFunction.VLookup(Cells(Tot_Row, 3), Table2, 7, False) + Application.WorksheetFunction.VLookup(Cells(Tot_Row, 2), Table2, 7, False) + Application.WorksheetFunction.VLookup(c1, Table2, 7, False)
    End If
    Tot_Row = Tot_Row + 1
Next
End Sub

I appreciate any help I can get

 

[jindon]

Try

Sub test()
    Dim a, i As Long, ii As Long, w, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("Profit&Loss")
        With .Range("d13", .Range("d" & Rows.Count).End(xlUp))
            a = .Offset(, -3).Resize(, 4).Value
            For i = 1 To UBound(a, 1)
                For ii = 1 To 3
                    If a(i, ii) <> "" Then
                        If Not dic.exists(a(i, ii)) Then
                            ReDim w(1 To 2): w(2) = 0
                            Set w(1) = CreateObject("System.Collections.ArrayList")
                        Else
                            w = dic(a(i, ii))
                        End If
                        w(1).Add i: dic(a(i, ii)) = w
                    End If
            Next ii, i
            With Sheets("Monthly")
                a = .Range("a27", .Range("a" & Rows.Count).End(xlUp)).Resize(, 7).Value
            End With
            For i = 1 To UBound(a, 1)
                If dic.exists(a(i, 1)) Then
                    w = dic(a(i, 1)): w(2) = w(2) + a(i, 7)
                    dic(a(i, 1)) = w
                End If
            Next
            With .Offset(, 1)
                On Error Resume Next
                .SpecialCells(2, 1).ClearContents
                On Error GoTo 0
                For Each e In dic
                    For i = 0 To dic(e)(1).Count - 1
                        .Cells(dic(e)(1)(i)).Value = _
                        .Cells(dic(e)(1)(i)).Value + dic(e)(2)
                    Next
                Next
            End With
        End With
    End With
End Sub

 

[Kristian]

That one works! But is it possible to move the array to a different sheet called for example "Array1" so it will be easier to add extra items to the list without adding column in Profit&Loss?