-
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.
Code:
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
-
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!
-
1 Attachment(s)
This seems to do it all, very slow, and test on a sample book - not original.
Code:
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
Attachment 13743
-
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.
-
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.
Code:
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
-
If you needed the pricing columns that had zero entries removed, this should work:
Code:
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...
Code:
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
-
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.
-
Down to 8 seconds...
Code:
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
