removing duplicates and merge all data into one line

[Patriot2879]

HI i really hope you can help me with the below query in VBA code in excel, i have the following issue with duplicates on a spreadsheet and mssing data on duplicate lines but i want this merged all into one line if possible.
-Sheet name = Sheet1
-Data range (column(s), rows) = A - Z
-Data-type (text, numbers, mixed) = mixed but for example column A will be a 13 number combination, column S will be notes added, column T will be customer contact details column V will be customer name, Column W will be address1, column X will be address2 and column Y will be postcode
-Expected result - Column A is the primary column but sometimes this is duplicated and on one line it could have notes, and on the next line notes are missing and the customer phone numner is in, and address1 on another line then address2 on another, but i want all this to be merged into one line and the other duplicate lines deleted. Can you help with this pleaser? i hope you can? your time is greatly apprecaited. Thank you

 

[wideboydixon]

Try this macro on a copy of the data (results can't be undone!):

Public Sub ConsolidateData()

Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim thisCol As Long

Application.ScreenUpdating = False

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 2
Do While thisRow <= lastRow
    If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
        lastCol = Cells(thisRow, Columns.Count).End(xlToLeft).Column
        For thisCol = 2 To lastCol
            If Cells(thisRow, thisCol).Value <> "" Then
                Cells(thisRow - 1, thisCol).Value = Cells(thisRow, thisCol).Value
            End If
        Next thisCol
        Cells(thisRow, "A").EntireRow.Delete xlShiftUp
        lastRow = lastRow - 1
    Else
        thisRow = thisRow + 1
    End If
Loop

Application.ScreenUpdating = True

End Sub

WBD

 

[Patriot2879]

Hi thank you for the code, i have tried this and made a new Macro called ConsolidateData i 'Run' the macro but it seems not to do anything in the document, everything stayed where it was and nothing merged. thankyou for your time.

What i did to test it was made the macro and duplicated the data twice then deleted informatio and left some blank cells, and then run the macro to see if it merged all the data into the correct line and delete the empty cells and duplicated cells, it didnt seem to do anything unfortuantely, i am very greatful for your help and time, and hope you can advise me again, thank you so much.

 

[wideboydixon]

Is the data sorted on column A when the macro is run? It assumes that this is the case. E.g. before:

Book1
	A	B	C	D	E
1	Ref	First	Second	Third	Fourth
2	0000000012345	ABC	DEF
3	0000000012345			GHI
4	0000000012345				JKL
Sheet1

After:

Book1
	A	B	C	D	E
1	Ref	First	Second	Third	Fourth
2	0000000012345	ABC	DEF	GHI	JKL
Sheet1

WBD

 

[Patriot2879]

Hiya yes that is exactly how I want it to look. What do you mean sorted in column A? Am I putting the code in correctly by adding a macro then running it? Thanks for your help

 

[wideboydixon]

Can you post a sample of the data that you're working with? As I said, the macro will only work if you first sort the data using Column A.

WBD

 

[Patriot2879]

i think it is working now i have done what you said now i have sorted column A from lowest to highsest and it seems good just need to check the data, thanks for your help on this much apprecaited

 

[Patriot2879]

Hi good afternoon, this code works amazing just one thing is thre any way if there are more than one contact number for example on 2 lines or more, is there any way to merge them into the one cell? with a comma after them? hope you can help and thanks again for your time

 

[Patriot2879]

sorry the contact numbers are in Column M and N if that helps? M is the code and N is the actual number

 

[wideboydixon]

Public Sub ConsolidateData()

Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim thisCol As Long

Application.ScreenUpdating = False

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 2
Do While thisRow <= lastRow
    If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
        lastCol = Cells(thisRow, Columns.Count).End(xlToLeft).Column
        For thisCol = 2 To lastCol
            If Cells(thisRow, thisCol).Value <> "" Then
                If Cells(thisRow - 1, thisCol).Value = "" Then
                    Cells(thisRow - 1, thisCol).Value = Cells(thisRow, thisCol).Value
                Else
                    Cells(thisRow - 1, thisCol).Value = Cells(thisRow - 1, thisCol).Value & ", " & Cells(thisRow, thisCol).Value
                End If
            End If
        Next thisCol
        Cells(thisRow, "A").EntireRow.Delete xlShiftUp
        lastRow = lastRow - 1
    Else
        thisRow = thisRow + 1
    End If
Loop

Application.ScreenUpdating = True

End Sub

This will merge any cells with data on more than one line.

WBD