Merge duplicate values in row into one column

[ilsley_excel]

Hi folks. I have a spreadsheet with a list of clients and their e-mails. However, the way the data comes into me is almost unworkable.

I need to go from this:

To this:

I'm trying to build a macro to consolidate the e-mail address data and make it discrete, but the way I'm doing it seems to be really long-winded.

Any ideas?

Thanks.

 

[ilsley_excel]

Hi folks. Just bumping this up in the hope that someone might be able to guide me in the right direction!

 

[mohadin]

Hi
what about

Sub test()
    Cells(1).CurrentRegion.SpecialCells(4).Delete Shift:=xlToLeft
End Sub

 

[ilsley_excel]

Hi
what about

Sub test()
    Cells(1).CurrentRegion.SpecialCells(4).Delete Shift:=xlToLeft
End Sub

That didn't work unfortunately. It shifts all values to the left and removes the blanks in between.

Thanks for trying however!

 

[bebo021999]

Try to attach a mini sheet (XL2BB) to give us something to test.

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

 

[ilsley_excel]

Try to attach a mini sheet (XL2BB) to give us something to test.

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

MergeIdenticalRowDataIntoColumns.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	UniqueID	Ref	Surname	Forename	Group	SubGroup	EMAIL1	EMAIL2	EMAIL3	EMAIL4	EMAIL5
2	ID2432	112266	Jones	Alex	G54	GA12	alex@alex.com			alex123@jones.com
3	ID2432	112266	Jones	Alex	G54	GA12			alex123@jones.com
4	ID2432	112266	Jones	Alex	G54	GA12					alex16@ert.com
5	ID6545	113442	Carter	Paul	G56	GD51		paulc@puly.com
6	ID5044	112278	Hale	Gemma	G55	GB13		gem@gemma.com		gem54@gem.org
7	ID5044	112278	Hale	Gemma	G55	GB13	gem@gemma.com				gemmah@gem.co.uk
8	ID6545	113442	Pole	George	G57	GC33	georgey@geog.com				georgey@geog.com
9	ID6545	113442	Pole	George	G57	GC33				geo121@geo.co.uk
Sheet1

 

[bebo021999]

Assum data is in sheet1, Output is in Sheet2, from cell A2:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, t&, rng, arr(1 To 100000, 1 To 7)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:K" & lr).Value
    For i = 1 To UBound(rng)
        For j = 7 To UBound(rng, 2)
            If Not dic.exists(rng(i, j)) And Not IsEmpty(rng(i, j)) Then
                dic.Add rng(i, j), ""
                k = k + 1: arr(k, 7) = rng(i, j)
                For t = 1 To 6
                    arr(k, t) = rng(i, t)
                Next
            End If
        Next
    Next
End With
With Sheets("Sheet2")
    .Range("A2").Resize(k, 7).Value = arr
End With
End Sub

 

[ilsley_excel]

Assum data is in sheet1, Output is in Sheet2, from cell A2:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, t&, rng, arr(1 To 100000, 1 To 7)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:K" & lr).Value
    For i = 1 To UBound(rng)
        For j = 7 To UBound(rng, 2)
            If Not dic.exists(rng(i, j)) And Not IsEmpty(rng(i, j)) Then
                dic.Add rng(i, j), ""
                k = k + 1: arr(k, 7) = rng(i, j)
                For t = 1 To 6
                    arr(k, t) = rng(i, t)
                Next
            End If
        Next
    Next
End With
With Sheets("Sheet2")
    .Range("A2").Resize(k, 7).Value = arr
End With
End Sub

Wow. That worked perfectly! Hero.

Thank you so much man! Really appreciate it.