Combine duplicate records and delete

[mvesaas]

Hi,

I have a veeerrry large spreadsheet that needs some formatting help. The sheet is a list of 5,000+ records, that list account details. Each account is tracked by a KEY number. Problem is that for any given account KEY, there may be 5-6 lines of information. I need to combine all the data for each listed account into one comprehensive line, then delete the duplicate files.

For example, Acct #102460 has three lines of information. The information in each line is slightly different, but each has the same KEY 102460. I need to take the detail information, combine it onto one line of info, then delete the other lines. Then move to the next acct KEY.

I have a general idea of how the code would verify the info, format, and move forward, but I have only used VBA in WORD, and am not very familiar with Excel VBA.

Any suggestions? I have attached a small example that shows how the data starts, then how I would like it to look once formatted correctly.

[MWE]

Hi,

I have a veeerrry large spreadsheet that needs some formatting help. The sheet is a list of 5,000+ records, that list account details. Each account is tracked by a KEY number. Problem is that for any given account KEY, there may be 5-6 lines of information. I need to combine all the data for each listed account into one comprehensive line, then delete the duplicate files.

For example, Acct #102460 has three lines of information. The information in each line is slightly different, but each has the same KEY 102460. I need to take the detail information, combine it onto one line of info, then delete the other lines. Then move to the next acct KEY.

I have a general idea of how the code would verify the info, format, and move forward, but I have only used VBA in WORD, and am not very familiar with Excel VBA.

Any suggestions? I have attached a small example that shows how the data starts, then how I would like it to look once formatted correctly.

I think this will do what you want.

Sub CleanUp()
Dim MainRow As Long
    Dim AuxRow As Long
    Dim MatchNum As Long
    Dim KeyCol As Long
MainRow = 2
    KeyCol = 1
    MatchNum = 0
    Do While Cells(MainRow, KeyCol) <> ""
        AuxRow = MainRow + 1
        Do While Cells(AuxRow, KeyCol) <> ""
            If Cells(MainRow, KeyCol) = Cells(AuxRow, KeyCol) Then
                MatchNum = MatchNum + 1
                Range(Cells(AuxRow, 17), Cells(AuxRow, 20)).Select
                Selection.Copy
                Range(Cells(MainRow, 17 + 4 * MatchNum), Cells(MainRow, 20 + 4 * MatchNum)).Select
                ActiveSheet.Paste
                Rows(AuxRow).Delete
                AuxRow = AuxRow - 1
            End If
            AuxRow = AuxRow + 1
        Loop
        MainRow = MainRow + 1
        MatchNum = 0
    Loop
End Sub

[mvesaas]

Thanks so much!!

Thank you, this is great. Works for exactly what I needed it to do. You just saved me about 8 hours of formatting time.

[MWE]

Thanks so much!!

Thank you, this is great. Works for exactly what I needed it to do. You just saved me about 8 hours of formatting time.

glad to help. Please mark the thread Solved.