Database/List Manipulation

[mperrah]

Making progress,
this finds matches of the price type and copies the account number to the appropriate column,
I'm working on then copying each row "J to DE" up a row if the address matches, but it overwrites the contents, work in progress.
I have made a table with price types as they appear on the sheet in Row 1 and another as they appear in Column EC on Sheets("Pricing")
I have code that builds an array with the pricing values without the indexing numbers, not sure yet how to utilize both parts.
My thought is to copy up the values one row at a time and if the cell above is full, offset 1 to right...
not sure if im on the right track, but this at least gets the account number in the appropriate columns....
(I had to convert the values in Row 1 and column EC to uppercase)

Sub combineAccounts()
Dim x, lr As Long
Dim ws As Worksheet
Dim aPtype As Variant

Set ws = Worksheets("S1-var")
    
    With ws
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        
        For x = lr To 3 Step -1
            
            Set pFnd = .Range("I1:DE1").Find(Left(Cells(x, "EC"), Len(Cells(x, "EC")) - 3), , Excel.xlValues)
            pFnd.Offset(x - 1).Value = Cells(x, 2).Value
            
        Next x
        'For p = lr To 3 Step -1
        '    If .Cells(p, "E") = .Cells(p - 1, "E") Then
        '    Range("J" & p & ":DE" & p).Copy Range("J" & p - 1)
        '     Cells(p, "D").Value = "To Delete"
        '    End If
        '
        'Next p
        
    End With
End Sub

Copy of vbax52868c.xlsm

[mperrah]

This seems to do it all, very slow, and test on a sample book - not original.

Sub combineAccounts()
Dim x, lr As Long
Dim ws As Worksheet
Dim aPtype As Variant

Application.ScreenUpdating = False

Set ws = Worksheets("S1-var")
    
    With ws
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        
        For x = lr To 3 Step -1
            Set pFnd = .Range("I1:DE1").Find(Left(Cells(x, "EC"), Len(Cells(x, "EC")) - 3), , Excel.xlValues)
            pFnd.Offset(x - 1).Value = Cells(x, 2).Value
        Next x
        
        For r = lr To 3 Step -1
            For c = 10 To 109
                If .Cells(r, "E") = .Cells(r - 1, "E") And _
                    Cells(r - 1, c).Value = "" Then
                    Cells(r, c).Copy Cells(r - 1, c)
                    Cells(r, "D").Value = "To Delete"
                ElseIf .Cells(r, "E") = .Cells(r - 1, "E") And _
                    Cells(r - 1, c).Value <> "" Then
                    Cells(r, c).Copy Cells(r - 1, c + 1)
                    Cells(r, "D").Value = "To Delete"
                   
                End If
            Next c
        Next r
    
        For d = lr To 3 Step -1
            If Cells(d, "D").Value = "To Delete" Then
            Cells(d, "D").EntireRow.Delete
            End If
        Next d
    
    End With
        
    Application.ScreenUpdating = True

End Sub

vbax52868d.xlsm