Match cells in column, then transpose matching row data from column b, c etc on many

[arcadian13]

I have a spreadsheet with multiple tabs, and would like to transpose the data on each tab in the way described below:

So if I have:
1 a
1 b
1 c
2 a
2 c
2 d

I would like to get

1 a b c
2 a c d

Same with multicolumn. if I have

1 a b c
1 d
2 e f g h
2 i j

Would like to get

1 a b c d
2 e f g h i j

Am a coding dummy, so appreciate any help

 

[arcadian13]

Wow, it works, which is brilliant, but even on a small sample, it takes a while to run (I tried it on the spreadsheet called 'before sort'). The real sheet contains thousands of lines. Any way of speeding it up?! Or do I just need a faster processor? If you could include the unwrapping of text in each tab, that would be wonderful.

Really appreciate the effort and trouble you have gone to

 

[MickG]

I,ve altered it very slightly, There's now a timer and a bit of code at the top , to set the column "width for column "B". There is no word wrap in the code, except what occurs naturally in Excel, I'm not sure how to do anything about that.
I tried this code with all the pages using the page with the largest amount of text for each page and it took about 3 seconds, which I thinks quite good considering what its got to do.
I don't think I can improve on this.

[COLOR="Navy"]Sub[/COLOR] MG28Jul43
'[COLOR="Green"][B]New Code MkII[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Lst         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ws          [COLOR="Navy"]As[/COLOR] Worksheet
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray
[COLOR="Navy"]Dim[/COLOR] ColMax      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] Wd
[COLOR="Navy"]Dim[/COLOR] tx
[COLOR="Navy"]Dim[/COLOR] t
t = Timer
Application.ScreenUpdating = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] ActiveWorkbook.Worksheets
    '[COLOR="Green"][B]Alter width to suit !![/B][/COLOR]
    Ws.Columns("B:B").ColumnWidth = 100
    [COLOR="Navy"]If[/COLOR] Not Ws.Name = "users" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
            .comparemode = vbTextCompare
[COLOR="Navy"]Set[/COLOR] Rng = Ws.Range(Ws.Range("A1"), Ws.Range("A" & Rows.Count).End(xlUp))
    ReDim Ray(1 To Rng.Count, 1 To 2)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] Dn > "" [COLOR="Navy"]Then[/COLOR]
        Lst = Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft).Column
         ColMax = Application.Max(ColMax, Lst)
            [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                    Ray(1, 1) = Ws.Range(Dn.Offset(, 1), Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft))
                    Ray(1, 2) = Lst
                    .Add Dn.Value, Array(Dn.Offset(, 1), Ray, 1, Lst)
                [COLOR="Navy"]Else[/COLOR]
                    Q = .Item(Dn.Value)
                        Q(2) = Q(2) + 1
                        Q(1)(Q(2), 1) = Ws.Range(Dn.Offset(, 1), Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft))
                        Q(1)(Q(2), 2) = Lst
                        
                        [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
                    .Item(Dn.Value) = Q
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]
'[COLOR="Green"][B]K = Each unique col "A"[/B][/COLOR]
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(k)(3) > 1 And Not Left(.Item(k)(0), 1) = "(" [COLOR="Navy"]Then[/COLOR]
        .Item(k)(0).Resize(, ColMax).Value = vbNullString
        '[COLOR="Green"][B]tx = the number of rows for any one unique[/B][/COLOR]
        [COLOR="Navy"]For[/COLOR] tx = 1 To .Item(k)(2)
             
             [COLOR="Navy"]If[/COLOR] .Item(k)(1)(tx, 2) = 2 [COLOR="Navy"]Then[/COLOR]
              .Item(k)(0).Value = .Item(k)(0).Value & "(" & .Item(k)(1)(tx, 1) & "),"
            [COLOR="Navy"]Else[/COLOR]
            '[COLOR="Green"][B]Ac = number of columns in each row for each unique[/B][/COLOR]
                [COLOR="Navy"]For[/COLOR] Ac = 1 To .Item(k)(1)(tx, 2) - 1
                   [COLOR="Navy"]If[/COLOR] Not .Item(k)(1)(tx, 1)(1, Ac) = vbNullString [COLOR="Navy"]Then[/COLOR]
                        Wd = Split(.Item(k)(1)(tx, 1)(1, Ac), " ")
                            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Wd)
                                [COLOR="Navy"]If[/COLOR] Ac = 1 [COLOR="Navy"]Then[/COLOR]
                                    .Item(k)(0).Value = .Item(k)(0).Value & "(" & Wd(n)
                                [COLOR="Navy"]Else[/COLOR]
                                    .Item(k)(0).Value = .Item(k)(0).Value & "_" & Wd(n)
                                [COLOR="Navy"]End[/COLOR] If
                             [COLOR="Navy"]Next[/COLOR] n
                    [COLOR="Navy"]End[/COLOR] If
                 [COLOR="Navy"]Next[/COLOR] Ac
            .Item(k)(0).Value = .Item(k)(0).Value & "),"
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] tx
  [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
.RemoveAll
[COLOR="Navy"]End[/COLOR] With
 
 [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
   [COLOR="Navy"]Set[/COLOR] nRng = Nothing
    Lst = 0
[COLOR="Navy"]End[/COLOR] If
ColMax = 0
[COLOR="Navy"]Next[/COLOR] Ws
Application.ScreenUpdating = True
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[arcadian13]

Wow! Not too shabby at all, 247 seconds for a sheet with about 2300 entries. This is amazing, and many many thanks for your help and patience, you have saved me huge amounts of work.

 

[MickG]

You welcome
Regard Mick

 

[arcadian13]

Hi Mick, me again! Our database size has just increased by 70%, and I am now getting an out of memory error. When i run the code on the previous day databse (the smaller size), all is fine. Any suggestions?!

 

[MickG]

All I can Suggest is you do each sheet seperately.
If that sound like an option you wil need to change the following lines.

'Rem out the line as shown below (this line is at the top of the code)
'For Each Ws In ActiveWorkbook.Worksheets
 'add the line here
Set  Ws = ActiveSheet
'Rem out this line at the bottom of the code
'Next Ws

Perhaps if your increased database means, just more sheets, then perhaps you could do a small number of sheet at a time.
Mick

 

[arcadian13]

Hi Mick, I tried first of all to use a sledge hammer to crack a nut. I used Excel 10 64 bit on a Windows 7 64 bit machine, and after 12 minutes, the process was done (i.e. I did not gte an error message). But I think there has been a change in the spreadsheet I am sent internally, which I use your code to process. I can't spot any difference myself, but in the the two links, one can see your macro somehow doubles up the entries in the 09Aug spreadsheet (it works fine in the 08Aug sheet). Any help appreciated as always!
http://www.4shared.com/office/Dx1WYQIt/UserData_08Aug.html
http://www.4shared.com/office/aADgVa4Y/UserData_09AUg.html

 

[MickG]

Ref:- "9Aug"
On line starting 1053 in sheet "societies" you data is duplicated, is this the reason ????

 

[arcadian13]

So sorry to have bothered you, you are totally correct. Many thanks again

 

[MickG]

No problem, I'm glad you eventually got it to work OK.
Regards Mick