Hi
I have following problem, i have 5 columns of data, the first column
is ID number. There can be many rows with the same ID. What I want to
achieve is to group values from one ID in one row.
For example I have:
a,cat,excel,12, ,4
a,2,4, ,fire
a, ,fire,543,12
b,qwerty,six,alpha,3
b,34,enter, ,3
c,with,sober,lax,23
c,2, ,4,3
and want to get:
a,cat,excel,12, ,4,2,4, ,fire, ,fire,543,12
b,qwerty,six,alpha,3,34,enter, 3
c,with,sober,lax,23,2, 4,3
Can this be done in excel or vba?
Relatively easy to do with a macro. You do not write where you want the results, so in this example I placed them adjacent to (starting in column H) your original data. But if it works OK, that can easily be changed. Also, this macro, does not expect that the data will be sorted. It does not sort the results, either, but that could easily be added.
Finally, it assumes your data starts in A1, and, like your example, has no column labels; again, an easy change to make if that is not the case.
To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.
Once satsfied, UNcommenting the Application.Screenupdating = False line will speed up execution.
======================================
Option Explicit
Sub CombineRows()
Dim rSrc As Range, rDest As Range, c As Range
Dim vSrc As Variant, vRes As Variant
Dim v1 As Variant, v2() As String
Dim collSrc As Collection
Dim i As Long, j As Long
Dim sTemp As String
Dim sFirstAddress As String
'Application.ScreenUpdating = False
Set rSrc = ActiveSheet.Range("a1").CurrentRegion
Set rDest = rSrc(1, rSrc.Columns.Count + 2)
rDest.CurrentRegion.Clear
'get list of unique ID's
Set collSrc = New Collection
On Error Resume Next
For Each c In rSrc.Columns(1).Cells
collSrc.Add Item:=c.Text, Key:=CStr(c.Text)
Next c
On Error GoTo 0
'Build Results array
ReDim vRes(1 To collSrc.Count, 0 To 1)
For i = 1 To collSrc.Count
vRes(i, 0) = collSrc(i)
Set c = rSrc.Find(what:=vRes(i, 0), _
after:=rSrc(rSrc.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlNext, MatchCase:=True)
sFirstAddress = c.Address
Do
v1 = Range(c.Offset(columnoffset:=1), _
c(columnindex:=Columns.Count).End(xlToLeft))
ReDim v2(1 To UBound(v1, 2))
For j = LBound(v2) To UBound(v2)
v2(j) = v1(1, j)
Next j
vRes(i, 1) = vRes(i, 1) & "," & Join(v2, ",")
Set c = rSrc.FindNext(after:=c)
Loop While c.Address <> sFirstAddress
vRes(i, 1) = Mid(vRes(i, 1), 2)
Next i
Set rDest = rDest.Resize(rowsize:=UBound(vRes, 1), columnsize:=2)
rDest = vRes
rDest.Columns(2).TextToColumns comma:=True, Tab:=False, semicolon:=False, _
Space:=False, other:=False
Application.ScreenUpdating = True
End Sub
================================
