Transposing non-uniform entries in one column to one row per entry

[impala_griffith]

Apologies if the title is confusing. Basically, I have a worksheet like this:

eu	Aar <tbody> </tbody>
otn	Aar ibaia
sp	Aaar
eu	Abidjan
dm	abidjandar
sp	Abidjan
en	Abidjan

<tbody>
</tbody>

where each grouping of column A and B (delimited by blank cells) is one "entry", and the cells in column A denote the language of the corresponding cell in column B. So for example, in the first entry (or grouping of cells, from A1 to B3), the word in basque (eu) is "Aar", in otn it's "Aar ibaia", and in spanish (sp) it's "Aar". As you can see, not all grouping of cells contain the same languages (meaning each grouping of cells can have different number of rows), and even the ones who do may not be in the same order.

What I want to do is to somehow transpose the sheet like so:

eu	dm	otn	sp	fr	en	sf	loc
Aar		Aar ibaia	Aar
Abidjan	abidjandar		Abidjan		Abidjan

<tbody>
</tbody>

So essentially, every grouping of cells is transposed into one row, with the cells of each grouping's different translations put in the corresponding column.

I don't want to bother anyone with writing an entire VBA script for this (unless you like to do it), but could someone point me in the right direction of how to do this? I was thinking of something along the lines of the following:

1. Make a master sheet with the columns being eu, dm, otn, sp, etc.

2. Write a VBA script for the sheet of data, where you select all the data and it conducts an If-then statement where if cell A1 = "eu", copy/ paste cell B1 in Sheet2 cell A2 then go to the next cell, if A1 = "dm", copy/paste cell B1 in Sheet2 cell B2 then go to the next cell, .... if cell A1 is empty, start in the next row in Sheet 2 (new entry).

Thank you so much for all your help. If there's any other information you need, I'd be happy to provide it.

 

[impala_griffith]

just to be clear, the original data looks like this:

eu	Aar
otn	Aar ibaia
sp	Aar
eu	Abidjan
dm	Abidjandar
sp	Abidjan
en	Abidjan

<tbody>
</tbody>

but with tons more entries. And I want the outcome to look like this:

eu	dm	otn	sp	fr	en	sf	loc
Aar		Aar ibaia	Aar
Abidjan	Abidjandar		Abidjan		Abidjan

<tbody>
</tbody>

also, I should note that all groupings of cells are delimited by a blank cell, and they all begin with the "eu" cell.

 

[MickG]

Try this:-
Nb:- your data assumed to start "A2"
Results start "A1" Sheet "Master"
Nb:- The code will provide the headers and the related data.

[COLOR="Navy"]Sub[/COLOR] MG09Jan33
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Omax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng = Rng.SpecialCells(xlCellTypeConstants, 2)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
       [COLOR="Navy"]If[/COLOR] Not Dic.Exists(R.Value) [COLOR="Navy"]Then[/COLOR]
            n = n + 1
            Dic.Add R.Value, Array(n, R)
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(R.Value)
            [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), R)
            Dic(R.Value) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
ReDim ray(1 To Rng.Count, 1 To Dic.Count + 1)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    ray(1, Dic(K)(0)) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] Dic(K)(1)
       [COLOR="Navy"]For[/COLOR] n = 1 To Rng.Areas.Count
            [COLOR="Navy"]If[/COLOR] Not Intersect(P, Rng.Areas(n)) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                num = n: [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
       [COLOR="Navy"]Next[/COLOR] n
       ray(n + 1, Dic(K)(0)) = P.Offset(, 1).Value
    [COLOR="Navy"]Next[/COLOR] P
 [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Master").Range("A1").Resize(Rng.Areas.Count + 1, Dic.Count)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[impala_griffith]

Thank you so much Mick, this was perfect.

 

[MickG]

You're welcome