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

 

[MickG]

Place this in a basic Module and run from the activesheet.

[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

 

[arcadian13]

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

 

[MickG]

Try this:-

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

 

[arcadian13]

Works, that is really fab, many thanks!

 

[MickG]

Your welcome
Regards Mick

 

[MickG]

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.

[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

 

[arcadian13]

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

<colgroup><col width="64" span="13" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[MickG]

Try this for to not sort "Users".
If it still fails, you need to supply the data it failed on !!

[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

 

[arcadian13]

"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):

User

Job title

Job description

Date from

Date to

Company name

About company

Company url

Location

Reference name

Reference number

Reference email

1

Title

2012-06-24

2012-08-23

Rest

1

Fugfg

Test

1

Profesor

Opasan posoa

2008-07-24

2011-07-24

Pros

http://skola.com

sko11

1123

tg@cc.com

1

Tytt

Test

1

Test

Test

12

Web Designer

Web and graphic designer.

2011-08-20

Eton Digital

http://etondigital.com

Novi Sad, Autonomna Pokrajina Vojvodina, Serbia

info@etondigital.com

74

Director

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.

2010-08-07

We Connect Students

A revolutionary recruitment portal that enables students and employers to connect.

http://weconnectstudents.com

London, England, United Kingdom

Clive Banks

7.92E+09

clive@weconnectstudents.com

74

Founder

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.

2008-03-04

2010-08-07

We Connect Students

A powerful search enables students to be found by the right employer for the right job.

http://weconnectstudents.com

Beccles, England, United Kingdom

75

Intern

Placement as part of my degree. Worked in all hotel areas, from Maintenance to Evening Host.

2011-06-06

2012-06-06

Manor on Golden Pond

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.

http://www.manorongoldenpond.com

Holderness, New Hampshire, United States

Brian Shields

brianps@roadrunnner.com

95

Public Relations Officer

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

2011-01-03

2011-01-06

United Kingdom Atomic Energy Authority

Leading research company in UK and Europe for Nuclear Fusion based power.

http://www.ccfe.ac.uk

Culham, England, United Kingdom

Chris Warrick

chris.warrick@ccfe.ac.uk

95

Sales and Marketing Team Leader

Planning, managing and carrying out a large scale marketing campaign. Leading a team in strategically launching a cost-effective campaign.

2012-01-26

We Connect Students

Online social community, putting students into the centre of a well connected system of companies who are looking for prospective graduates to employ.

http://www.weconnectstudents.com

Oliver ****inson

oliver@weconnectstudents.com

95

Intern

Shadowing and administrative work with additional research into investments and presentations to the heads of department summarising my findings.

2006-06-01

2006-07-01

Prudential Assurance

Prudential plc is an international financial services group with significant operations in Asia, the US and the UK

http://www.prudential.co.uk

London, England, United Kingdom

<colgroup><col span="15"></colgroup><tbody>
</tbody>