putting data from several cells in one cell together

[ivovandenberk]

Hi,

I have a sheet with 2 colomns: client number and document number, as follows:

Client number Document number
1234 100012
1234 100042
4321 102233
4321 249123
4321 533213
4567 134123
7890 123451
7890 125675
7890 357353

I need to have a unique client numnber on 1 row with all his documents in one cell, as follows:

client number: document number
1234 100012, 100042
4321 102233, 249123, 533213
4567 134123
7890 123451, 125675, 357353

I guess this can be done with a macro, but I have no experience in this. I hope anyone here can solve my problem. Thanks

Ivo

 

[doofusboy]

Assuming your data is in columns A and B, the following can get you most of the way there:

Place this formula in Cell D1: =A1&" "&B1
Place this formula in Cell D2: =IF(A2=A1,D1&", "&B2,A2&" "&B2)
Copy the second formula down column D as far as needed

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG10Oct11
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
.Add Dn.Value, Array(Dn.Address, Dn.Offset(, 1))
[COLOR="Navy"]Else[/COLOR]
 Q = .Item(Dn.Value)
    [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] nRng = Dn
    [COLOR="Navy"]Else[/COLOR]
         [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
    [COLOR="Navy"]End[/COLOR] If
    Q(1) = Q(1) & ", " & Dn.Offset(, 1)
    Range(Q(0)).Offset(, 1) = Q(1)
.Item(Dn.Value) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[hiker95]

ivovandenberk,


Sample raw data in worksheet Sheet1 (with the data already sorted/grouped):

Excel Workbook
	A	B
1	Client number	Document number
2	1234	100012
3	1234	100042
4	4321	102233
5	4321	249123
6	4321	533213
7	4567	134123
8	7890	123451
9	7890	125675
10	7890	357353
11
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B
1	Client number	Document number
2	1234	100012, 100042
3	4321	102233, 249123, 533213
4	4567	134123
5	7890	123451, 125675, 357353
6
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 10/10/2011
' http://www.mrexcel.com/forum/showthread.php?t=584522
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, a As Long, SR As Long, ER As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(1), Unique:=True
wR.Range("B1").Value = w1.Range("B1").Value
LR = wR.Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To LR Step 1
  SR = Application.Match(wR.Cells(a, 1), w1.Columns(1), 0)
  ER = Application.Match(wR.Cells(a, 1), w1.Columns(1), 1)
  If SR = ER Then
    wR.Range("B" & a) = w1.Range("B" & SR).Value
  Else
    wR.Cells(a, 2) = Join(Application.Transpose(w1.Range("B" & SR & ":B" & ER)), ", ")
  End If
Next a
wR.Columns("A:B").AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.


If you would prefer the results to be in the same worksheet as your raw data, I can re-write the macro to put the results into columns D and E.

 

[machopicho]

Sub test()
n = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To n
  For rr = r + 1 To n
    If Range("A" & rr) = Range("A" & r) Then
    Range("B" & r) = Range("B" & r) & "#" & Range("B" & rr)
    Range("A" & rr & ":" & "B" & rr).ClearContents
    End If
 Next rr
 If Range("A" & r) = "" Then
 Range("A" & r & ":" & "B" & r).Delete
 End If
 Next r
End Sub

Enjoy!

 

[ivovandenberk]

Wow, thanks for all the quick replies! the second reply did the trick. I tried all of them, but the second one (MickG) worked (for me ). Hiker95s solution got me a 'subscript is out of range (error 9 during execution)' error (or something like that, my excel is in a different language). MachoPichos solution almost got me there, some client numbers however still got on two rows (using the example above, I still got two lines with client number 4321).

Thanks anyway for the quick responses!

greetings,

Ivo