Excel 2007 Macro moves duplicates
I have no idea about Excel macros at first, so I really don't know what I am doing about this, but any help would be enormously appreciated.
I have a table with columns (no headers) in rows A - G.
Column A contains the ID, and what I want to do is strip any duplicate IDs from the column structure to the row structure. There can be up to 9 lines to be moved by ID.
eg. Current format:
Row 1 - ID123 / Bob / James / 12345 / 1 / A1 / 120
Row 2 - ID124 / John / Smith / 2351 / 5 / C2 / 121
Row 3 - ID124 / John / Smith / 25562 / 1 / A2 / 162
Row 4 - ID162 / Gary / Barlow / 251767 / 9 / B1 / 167
Target format:
Row 1 - ID123 / Bob / James / 12345 / 1 / A1 / 120
Row 2 - ID124 / John / Smith / 2351 / 5 / C2 / 121 / 25562 / 1 / A2 / 162
Row 3 - ID162 / Gary / Barlow / 251767 / 9 / B1 / 167
So my question is a) is it doable b) How would I go about doing this (I'm happy to make this solution myself, but since I'm a VBA beginner, heading in the right direction would be handy!)
What the data will look like before applying the macro
How the data will ultimately look like
source to share
You may try. He uses an object dictionary
. This solution assumes that each line starts with a pattern Row 1 - ID123 / Bob / James
.
Option Explicit
Sub mergeDuplicates()
Dim d As Object
Dim rng As Range
Dim vArr As Variant
Dim i As Integer, j As Integer
Set rng = Sheets(3).Range("A2:H5")
Set d = CreateObject("Scripting.Dictionary")
vArr = rng.Value
For i = LBound(vArr) To UBound(vArr)
If Not d.Exists(vArr(i, 2)) Then '-- check for unique ID
d.Add vArr(i, 2), Trim(Replace(vArr(i, 1), "-", ""))
For j = 2 To UBound(vArr, 2)
d.Item(vArr(i, 2)) = d.Item(vArr(i, 2)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
Next j
Else
For j = 5 To UBound(vArr, 2)
d.Item(vArr(i, 2)) = d.Item(vArr(i, 2)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
Next j
End If
Next i
'-- output to sheet
rng.Offset(5).Resize(UBound(d.items) + 1, 1) = Application.Transpose(d.items)
'-- split the text to columns
rng.Offset(5).Resize(UBound(d.items) + 1, 1).TextToColumns Destination:= _
rng.Offset(5), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="/"
Set d = Nothing
End Sub
Output:
AS for OP's comments and updates
Change the content for loop
in accordance with its real data.
For i = LBound(vArr) To UBound(vArr)
If Not d.Exists(vArr(i, 1)) Then '-- check for unique ID
d.Add vArr(i, 1), Trim(vArr(i, 1)) '-- add RowID as first element in item
For j = 2 To UBound(vArr, 2) '-- then append each element(column) to the first element
d.Item(vArr(i, 1)) = d.Item(vArr(i, 1)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
Next j
Else
For j = 4 To UBound(vArr, 2) '-- when duplicates found, append from 4th column
d.Item(vArr(i, 1)) = d.Item(vArr(i, 1)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
Next j
End If
Next i
Result based on OP's updated sample data:
source to share