Database/List Manipulation

[mperrah]

Ok, be patient. This code takes for ever, but it copies all the accounts across then copies them up and puts a "To Delete" in column "D"
if the cell above is occupied it moves over 1 top right for the copy.
Maybe the real gurus can modify this to speed up process.

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
           'Cells(r, c).EntireRow.Delete
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

[DarinM]

Wow this is terrific! I love it, I am just about to leave the office and saw your thread reply. This is great, i will have to look it over monday... I don't mind it taking long if it works!

i just for fun uncommented your delete rows, r,c and entire thing got wiped lol

have a good weekend!

[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

[DarinM]

Thank you so much mperrah! I believe it is working great

One thing that may be useful, is to have another piece of code assigned to a separate button, that after we sort, we can delete the empty and unused columns, so that we don't need to scroll over useless/empty ones. The columns may or may not be full depending on the data we decide to export.

If that's too much to ask then I am still a happy camper!

Also, regarding the cleaning up the database, if we have to do it manually here, I'll be flagging all the accounts that are off by a bit and assigning people sets of data to fix. It'll be a one-time fix, and ill make sure going forward they copy/paste from the previous account address if another is to be added.

[mperrah]

Deleting columns is pretty straight forward. You mean delete the pricing columns that have no values?
We can script that. Give me a few...

I am currently trying to speed up the macro I posted that is working.
I am at an impass, by my reasonging this should work, but it fails to copy over to the next blank column.
It runs much faster, but leaves out the accounts with multiple values in the same pricing structure. I'll keep on it unless someone else can see what I'm missing:
I tried to eliminate a few of the redundant loops through the data, but cant see where I'm flawed.

Sub combineAccounts_v2()
Dim lr, x, r, c, d As Long
Dim ws As Worksheet

Application.ScreenUpdating = False

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

End Sub

[mperrah]

If you needed the pricing columns that had zero entries removed, this should work:

Sub remEmptyCol()
Dim lr, r, c  As Integer

Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row

    For c = 109 To 10 Step -1
        rCnt = 0
            For r = lr To 3 Step -1
                If Cells(r, c).Value = "" Then
                    rCnt = rCnt + 1
                End If
            Next r
                If rCnt = lr - 2 Then
                    Cells(r, c).EntireColumn.Delete
                End If
    Next c
Application.ScreenUpdating = True
End Sub

This is the latest version of the main code I'm still trying to trim down.
It takes around 60 seconds on my machine...

Sub combineAccounts_v1b()
Dim x, lr As Long
Dim ws As Worksheet

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
            If .Cells(r, "E") = .Cells(r - 1, "E") Then
                For c = 10 To 109
                    
                    If Cells(r - 1, c).Value = "" Then
                       Cells(r, c).Copy Cells(r - 1, c)
                       Cells(r, "D").Value = "To Delete"
                    
                    ElseIf 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
            End If
        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

[mperrah]

As far as scrubbing your data,
I used auto-filter under the "data" ribbon tab: it will combine matching entries and sort alphabetically.
so un-check "select all", and look for a close match then check those few and click "ok",
then edit as needed,
go back to filters, un-check those fixed entries,
look for a few more close entries, check them for editing and click "ok" again,
repeat till you're through the data.
It only took me a few minutes this way, but I'm not positive what entries can be combined where you should be.
The tricky part is Rm and Ste can be spread out alphabetically, as well as some have the Ste # before the street address...
Hopefully once these are fixed your reports should go much more smoothly.

[mperrah]

Down to 8 seconds...

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

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, c).Value <> "" 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, c).Value <> "" 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