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

A

arcadian13

New Member
Joined
Jul 23, 2012
Messages
22
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
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
Place this in a basic Module and run from the activesheet.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG23Jul07
[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"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]With[/COLOR] ActiveSheet
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A1"), .Range("A" & Rows.count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            Lst = Cells(Dn.Row, Columns.count).End(xlToLeft).Column
            [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                .Add Dn.Value, Array(Dn, Lst)
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Dn.Value)
                    Q(0).Offset(, Q(1)).Resize(, Lst).Value = Dn.Offset(, 1).Resize(, Lst).Value
                    Q(1) = Cells(Q(0).Row, Columns.count).End(xlToLeft).Column
                        [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"]Next[/COLOR]
[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"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
That is like fire to a caveman - magic! Have tested, and it looks like it works. Can you change it to run on all the tabs in a given workbook in one go? At the moment, it runs on a tab at a time when I am in the tab, and then run the macro
 
Upvote 0
Try this:-
Code: 
Sub Mult_Ws()
Dim Rng         As Range
Dim Dn          As Range
Dim Lst         As Integer
Dim nRng        As Range
Dim Q
Dim Ws As Worksheet
For Each Ws In ActiveWorkbook.Worksheets
With CreateObject("scripting.dictionary")
   .CompareMode = vbTextCompare
Set Rng = Ws.Range(Ws.Range("A1"), Ws.Range("A" & Rows.Count).End(xlUp))
For Each Dn In Rng
            Lst = Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft).Column
            If Not .Exists(Dn.Value) Then
                .Add Dn.Value, Array(Dn, Lst)
            Else
                Q = .Item(Dn.Value)
                    Q(0).Offset(, Q(1)).Resize(, Lst).Value = Dn.Offset(, 1).Resize(, Lst).Value
                    Q(1) = Ws.Cells(Q(0).Row, Columns.Count).End(xlToLeft).Column
                        If nRng Is Nothing Then
                            Set nRng = Dn
                        Else
                            Set nRng = Union(nRng, Dn)
                        End If
                .Item(Dn.Value) = Q
            End If
Next
End With
 
 If Not nRng Is Nothing Then nRng.EntireRow.Delete
   Set nRng = Nothing
    Lst = 0
Next Ws
End Sub
 
Upvote 0
It would help me & others if you try to keep you requests within the thread'
Try this for you PM.
NB:- This code is also for Multi sheets.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG25Jul57
[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"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] Ws [COLOR="Navy"]As[/COLOR] Worksheet
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] ActiveWorkbook.Worksheets
[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))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   [COLOR="Navy"]Set[/COLOR] Ac = Ws.Range(Dn.Offset(, 1), Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft))
    
    [COLOR="Navy"]If[/COLOR] Ac.Count = 1 [COLOR="Navy"]Then[/COLOR]
        Txt = Ac.Value
    [COLOR="Navy"]Else[/COLOR]
        Txt = "(" & Join(Application.Transpose(Application.Transpose(Ac.Value)), "_") & ")"
    [COLOR="Navy"]End[/COLOR] If
          Ac = vbNullString
          
            [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                .Add Dn.Value, Array(Dn, Txt)
                 Dn.Offset(, 1) = Txt
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Dn.Value)
                   Q(1) = Q(1) & "," & Txt
                     Q(0).Offset(, 1).Value = Q(1)
                        [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"]Next[/COLOR]
.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"]Next[/COLOR] Ws
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks for this. It gives me an error. Best way to see the problem is via a before and after attachment, but can't include those. One more thing: I realise now I don't want a tab (which will always be called "users") to be sorted.

After sorting two tabs in the right way, it gave an error for a tab , and then the other tabs were left unsorted

[TABLE="width: 832"]
<colgroup><col width="64" span="13" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64, align: right"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Try this for to not sort "Users".
If it still fails, you need to supply the data it failed on !!
Code: 
[COLOR="Navy"]Sub[/COLOR] Mult_Ws()
[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"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] Ws [COLOR="Navy"]As[/COLOR] Worksheet
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] ActiveWorkbook.Worksheets
[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))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   
   [COLOR="Navy"]Set[/COLOR] Ac = Ws.Range(Dn.Offset(, 1), Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft))
    
    [COLOR="Navy"]If[/COLOR] Ac.Count = 1 [COLOR="Navy"]Then[/COLOR]
        Txt = Ac.Value
    [COLOR="Navy"]Else[/COLOR]
        Txt = "(" & Join(Application.Transpose(Application.Transpose(Ac.Value)), "_") & ")"
    [COLOR="Navy"]End[/COLOR] If
          Ac = vbNullString
          
            [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                .Add Dn.Value, Array(Dn, Txt)
                 Dn.Offset(, 1) = Txt
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Dn.Value)
                   Q(1) = Q(1) & "," & Txt
                     Q(0).Offset(, 1).Value = Q(1)
                        [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"]Next[/COLOR]
.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
[COLOR="Navy"]Next[/COLOR] Ws
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
"users" now remains untouched (which is correct), but get the same error (runtime error 13, type mismatch), and the debug highlights

Txt = "(" & Join(Application.Transpose(Application.Transpose(Ac.Value)), "_") & ")"

Again, as before, the remaining tabs are unsorted

The data on the tab the macro gets stuck on looks like this (sorry if it is unhelpful):

[TABLE="width: 960"]
<colgroup><col span="15"></colgroup><tbody>[TR]
[TD]User[/TD]
[TD]Job title[/TD]
[TD]Job description[/TD]
[TD]Date from[/TD]
[TD]Date to[/TD]
[TD]Company name[/TD]
[TD]About company[/TD]
[TD]Company url[/TD]
[TD]Location[/TD]
[TD]Reference name[/TD]
[TD]Reference number[/TD]
[TD="colspan: 2"]Reference email[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]Title[/TD]
[TD][/TD]
[TD]2012-06-24[/TD]
[TD]2012-08-23[/TD]
[TD]Rest[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]Fugfg[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]Profesor[/TD]
[TD]Opasan posoa[/TD]
[TD]2008-07-24[/TD]
[TD]2011-07-24[/TD]
[TD]Pros[/TD]
[TD][/TD]
[TD="colspan: 2"]http://skola.com[/TD]
[TD]sko11[/TD]
[TD="align: right"]1123[/TD]
[TD="colspan: 2"]tg@cc.com[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]Tytt[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Web Designer[/TD]
[TD]Web and graphic designer.[/TD]
[TD="colspan: 2"]2011-08-20[/TD]
[TD="colspan: 2"]Eton Digital[/TD]
[TD]http://etondigital.com[/TD]
[TD="colspan: 3"]Novi Sad, Autonomna Pokrajina Vojvodina, Serbia[/TD]
[TD="colspan: 3"]info@etondigital.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]74[/TD]
[TD]Director[/TD]
[TD]Students can use WCS from day 1, year 1 of their university career to create a professional profile and expose themselves to employers.
Students can choose to be mentored by industry experts offering advice pertaining to the real world and be invited to events by employers. WCS provides students with the ability to network their way to success.[/TD]
[TD="colspan: 2"]2010-08-07[/TD]
[TD]We Connect Students[/TD]
[TD]A revolutionary recruitment portal that enables students and employers to connect.[/TD]
[TD]http://weconnectstudents.com[/TD]
[TD]London, England, United Kingdom[/TD]
[TD]Clive Banks[/TD]
[TD="align: right"]7.92E+09[/TD]
[TD="colspan: 4"]clive@weconnectstudents.com[/TD]
[/TR]
[TR]
[TD="align: right"]74[/TD]
[TD]Founder[/TD]
[TD]We Connect Students is the new online social community which places students in the centre of a well-connected, professional environment of employers and industry mentors looking to identify and attract graduate talent.

WCS brings together students, employers and mentors in a focused, professional way while allowing criteria like social mobility to be taken into account.[/TD]
[TD]2008-03-04[/TD]
[TD]2010-08-07[/TD]
[TD]We Connect Students[/TD]
[TD]A powerful search enables students to be found by the right employer for the right job.[/TD]
[TD]http://weconnectstudents.com[/TD]
[TD="colspan: 4"]Beccles, England, United Kingdom[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]75[/TD]
[TD]Intern[/TD]
[TD]Placement as part of my degree. Worked in all hotel areas, from Maintenance to Evening Host.[/TD]
[TD]2011-06-06[/TD]
[TD]2012-06-06[/TD]
[TD]Manor on Golden Pond[/TD]
[TD]The Manor has 24 guest bedrooms, a spa, tennis court and a heated outdoor swimming pool. The hotel is AAA 4 diamond and is also a member of Small Luxury Hotels and Wine Spectator.[/TD]
[TD]http://www.manorongoldenpond.com[/TD]
[TD]Holderness, New Hampshire, United States[/TD]
[TD="colspan: 2"]Brian Shields[/TD]
[TD="colspan: 3"]brianps@roadrunnner.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]95[/TD]
[TD]Public Relations Officer[/TD]
[TD]Designing and publishing material for the public.
Participating in the public outreach programme "The Sun Dome", inc. Giving lectures at schools
Guiding tours for the public around the site[/TD]
[TD]2011-01-03[/TD]
[TD]2011-01-06[/TD]
[TD]United Kingdom Atomic Energy Authority[/TD]
[TD]Leading research company in UK and Europe for Nuclear Fusion based power.[/TD]
[TD]http://www.ccfe.ac.uk[/TD]
[TD]Culham, England, United Kingdom[/TD]
[TD="colspan: 2"]Chris Warrick[/TD]
[TD="colspan: 3"]chris.warrick@ccfe.ac.uk[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]95[/TD]
[TD]Sales and Marketing Team Leader[/TD]
[TD]Planning, managing and carrying out a large scale marketing campaign.
Leading a team in strategically launching a cost-effective campaign.[/TD]
[TD="colspan: 2"]2012-01-26[/TD]
[TD]We Connect Students[/TD]
[TD]Online social community, putting students into the centre of a well connected system of companies who are looking for prospective graduates to employ.[/TD]
[TD="colspan: 2"]http://www.weconnectstudents.com[/TD]
[TD="colspan: 2"]Oliver ****inson[/TD]
[TD="colspan: 4"]oliver@weconnectstudents.com[/TD]
[/TR]
[TR]
[TD="align: right"]95[/TD]
[TD]Intern[/TD]
[TD]Shadowing and administrative work with additional research into investments and presentations to the heads of department summarising my findings.[/TD]
[TD]2006-06-01[/TD]
[TD]2006-07-01[/TD]
[TD]Prudential Assurance[/TD]
[TD]Prudential plc is an international financial services group with significant operations in Asia, the US and the UK[/TD]
[TD]http://www.prudential.co.uk[/TD]
[TD="colspan: 4"]London, England, United Kingdom[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Matching two columns cell for cell
Replies
2
Views
142
jolivanes
jolivanes
C
  • Solved
Transposing Columns to Rows
2
Replies
10
Views
194
Fluff
Fluff
R
  • Question Question
How to copy a range of data if two cells match
Replies
2
Views
249
rockychelsea
R
R
  • Solved
How to independently sort multiple columns of this SEQUENCE output without effecting the positions of the columns and of the blanks?
2
Replies
15
Views
459
Rnkhch
R
E
  • Solved
Looking for a spilled formula returning the value in a table matching 3 conditions
Replies
5
Views
137
ED38
E

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top