Transpose equal segments of rows into piled columns

[occitan]

Hello everybody!

I woud kindly like to ask you a question on transposing segments of rows into piled columns. I looked for similar cases on the forum but I didn't find any :/

Many thanks to whoever would like to help me!

So, I have to create a macro which enables to transpose different (equal) segments of rows into columns in this particular fashion:


A1 A1 A1 A1 B1 B1 B1 B1 C1 C1 C1 C1 D1 D1 D1 D1 E1 E1 E1 E1 ... (first row)
A2 A2 A2 A2 B2 B2 B2 B2 C2 C2 C2 C2 D2 D2 D2 D2 E2 E2 E2 E2 ... (second row)
A3 A3 A3 A3 B3 B3 B3 B3 C3 C3 C3 C3 D3 D3 D3 D3 E3 E3 E3 E3 ... (third row)
...

Into:

A1 B1 C1 D1 E1 ...
A1 B1 C1 D1 E1 ...
A1 B1 C1 D1 E1 ...
A1 B1 C1 D1 E1 ...
A2 B2 C2 D2 E2 ...
A2 B2 C2 D2 E2 ...
A2 B2 C2 D2 E2 ...
A2 B2 C2 D2 E2 ...
A3 B3 C3 D3 E3 ...
A3 B3 C3 D3 E3 ...
A3 B3 C3 D3 E3 ...
A3 B3 C3 D3 E3 ...
... ... ... ... ... ...


I simplified this example, in order to make it clear. In this example, each row consists of 5 elements (A, B, C, D, E -cell values-) which are taken in a group of 4, and have to be transposed into piled columns. In my case, I have 14 elements in each row paired in groups of 133 (instead of 4 in this example).

I tried several attempts in writing macros but I didn't manage to obtain this :/ Also, as I said, I wasn't able to find a solution already existing in the forum.

Many thanks to whoever will be so kind to help me.

O

 

[MickG]

Assuming the Unique Character for each Group is the first character in each cell i.e (A,B,C etc), then try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG16Nov02
[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] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
Ray = ActiveSheet.Cells(1).CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
  [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
    Txt = Left(Ray(n, Ac), 1)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        ReDim nray(1 To 1)
           nray(1) = Ray(1, Ac)
        .Add Txt, nray
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Txt)
        ReDim Preserve Q(1 To UBound(Q) + 1)
        Q(UBound(Q)) = Ray(n, Ac)
        .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    Sheets("Sheet2").Cells(1, c).Resize(UBound(.Item(K))).Value = .Item(K)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[occitan]

Hi Mick!

Thank you very much for your kind reply.

My apologies, I did not properly clarified this.

In fact, the elements of each group (eg A1 A1 A1 A1) are different from each other (they are numerical values). I used the former notation just to map them in the rows, but every value is different from each other.

That's why it is so difficult for me to solve this issue :/

I still cannot find a proper macro for this

O.

Assuming the Unique Character for each Group is the first character in each cell i.e (A,B,C etc), then try this for results on sheet2.

[COLOR=navy]Sub[/COLOR] MG16Nov02
[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] Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, Ray [COLOR=navy]As[/COLOR] Variant, Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
Ray = ActiveSheet.Cells(1).CurrentRegion
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] n = 1 To UBound(Ray, 1)
  [COLOR=navy]For[/COLOR] Ac = 1 To UBound(Ray, 2)
    Txt = Left(Ray(n, Ac), 1)
        [COLOR=navy]If[/COLOR] Not .Exists(Txt) [COLOR=navy]Then[/COLOR]
        ReDim nray(1 To 1)
           nray(1) = Ray(1, Ac)
        .Add Txt, nray
    [COLOR=navy]Else[/COLOR]
        Q = .Item(Txt)
        ReDim Preserve Q(1 To UBound(Q) + 1)
        Q(UBound(Q)) = Ray(n, Ac)
        .Item(Txt) = Q
    [COLOR=navy]End[/COLOR] If
  [COLOR=navy]Next[/COLOR] Ac
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    c = c + 1
    Sheets("Sheet2").Cells(1, c).Resize(UBound(.Item(K))).Value = .Item(K)
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Can you show an example from your actual data, that shows how each group is defined as belonging to that group ???
I assume there is some relationship that defines each group !!
Perhaps its the 133 in each group that defines a group ??

 

[Fluff]

If you always have 14 groups of 133 values each. How about

Sub Trans()

    Dim Cols As Long
    Dim Rws As Long
    Dim clmn As Long
    
    clmn = 1
    For Rws = 1 To Range("A1").CurrentRegion.Rows.Count
        For Cols = 1 To 1862 Step 133
            Sheets("[COLOR=#ff0000]Sheet3[/COLOR]").Cells(Rows.Count, clmn).End(xlUp).Offset(1).Resize(133).Value = Application.Transpose(Cells(Rws, Cols).Resize(, 133).Value)
        Next Cols
        clmn = clmn + 1
    Next Rws
    Sheets("[COLOR=#ff0000]Sheet3[/COLOR]").Rows(1).Delete

End Sub

Change the sheet name in red to suit. & have the data sheet active when you run this.

 

[occitan]

Dear Mick, Dear Fluff,

thank you very much for your answers!

And manythanks to Fluff for kindly providing me the macro. With reference to this,however, I noticed that your macro, from my original setting:

A1 A1 A1 A1 B1 B1 B1 B1 ...
A2 A2 A2 A2 B2 B2 B2 B2 ...
A3 A3 A3 A3 B3 B3 B3 B3 ...
A4 A4 A4 A4 B4 B4 B4 B4 ...
...



produces thefollowing results:


A1 A2 A3 A4 ...
A1 A2 A3 A4 ...
A1 A2 A3 A4...
A1 A2 A3 A4...
B1 B2 B3 B4...
B1 B2 B3 B4...
B1 B2 B3 B4...
B1 B2 B3 B4...
... ... ... ... ...

i.e., it transposes separate segments for each rows in block matrixes.


What I would need, instead, would be:

A1 B1 C1 ...
A1 B1 C1 ...
A1 B1 C1 ...
A1 B1 C1 ...
A2 B2 C2 ...
A2 B2 C2 ...
A2 B2 C2 ...
A2 B2 C2 ...
...


I apologize for Mick, I will try to be more precise. Consider, e.g., this:

1 2 3 4 ¦ 10 20 30 40 ¦ 100 200 300 400 ¦ ... ¦ 130th value 131th value 132th value 133th value ¦ (row 1)
5 6 7 8 ¦ 50 60 70 80 ¦ 500 600 700 800 ¦ ... ¦ 130th value 131th value 132th value 133th value ¦ (row 2)
...

From this, what I need is to obtain:

1 10 100 ...
2 20 200 ...
3 30 300 ...
4 40 400 ...
5 50 500 ...
6 60 600 ...
7 70 700 ...
8 80 800 ...
...

As I specified yesterday, each segment comprehends not 4 elements like in this simplifying example, but 14.

I realize it is not easy, that is why I'm driving mad with writing down the right macro (but haven't managed so far) :/

Many thanks whether you could kindly provide me some help!

O.

 

[occitan]

Sorry, I messed up the format. here's the correct one!


1 2 3 4 | 10 20 30 40 | 100 200 300 400 | ... | 130th value 131th value 132th value 133th value | (row 1)
5 6 7 8 | 50 60 70 80 | 500 600 700 800 | ... | 130th value 131th value 132th value 133th value | (row 2)
...

Where "|" is just a visual addition I put here to separate each group (consisting of not 4 but 14 elements) in each row.

Many thanks!

 

[Fluff]

How about

Sub Trans()

    Dim Cols As Long
    Dim Rws As Long
    Dim clmn As Long
    
    clmn = 1
    For Cols = 1 To 1862 Step 133
        For Rws = 1 To Range("A1").CurrentRegion.Rows.Count
            Sheets("sheet3").Cells(Rows.Count, clmn).End(xlUp).Offset(1).Resize(133).Value = Application.Transpose(Cells(Rws, Cols).Resize(, 133).Value)
        Next Rws
        clmn = clmn + 1
    Next Cols
    Sheets("Sheet3").Rows(1).Delete

End Sub

 

[MickG]

Try this for results on sheet2.
I'm not sure I'm using the right criteria ,but:-
NB:-If you ever change the group size from 14, then change the Constant "CoNum" at top of code to reflect that.
I assumed that thing that defines groups between the Elements are related by gaps between the values in each element i.e. (1, 10,100etc)

[COLOR=navy]Sub[/COLOR] MG17Nov07
[COLOR=navy]Dim[/COLOR] Ray [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] St [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nGap [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] K [COLOR=navy]As[/COLOR] Variant
Const ColNum = 14
Ray = ActiveSheet.Range("A1").CurrentRegion
c = 1
ReDim nray(1 To UBound(Ray, 1) * (UBound(Ray, 2)), 1 To ColNum)
[COLOR=navy]For[/COLOR] n = 1 To UBound(Ray, 1)
 [COLOR=navy]For[/COLOR] Ac = 1 To UBound(Ray, 2)
    St = St + 1
     nray(c, St) = Ray(n, Ac)
    [COLOR=navy]If[/COLOR] Ac Mod ColNum = 0 [COLOR=navy]Then[/COLOR]
        c = c + 1: St = 0
    [COLOR=navy]End[/COLOR] If
     
 [COLOR=navy]Next[/COLOR] Ac
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] n = 1 To c - 1
    [COLOR=navy]For[/COLOR] Ac = 1 To ColNum
        nGap = nray(n, 2) - nray(n, 1)
            [COLOR=navy]If[/COLOR] Not .Exists(nGap) [COLOR=navy]Then[/COLOR]
                .Add nGap, nray(n, Ac)
            [COLOR=navy]Else[/COLOR]
                .Item(nGap) = .Item(nGap) & "," & nray(n, Ac)
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Ac
[COLOR=navy]Next[/COLOR] n
c = 0
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    c = c + 1
    sp = Split(.Item(K), ",")
    Sheets("Sheet2").Cells(1, c).Resize(UBound(sp) + 1).Value _
    = Application.Transpose(sp)
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[occitan]

Dear Fluff, thank you very much for your kind help. The macro is not correct yet, but almost close to it!

Also many thanks to Mick.

Thank you very much for the kind help you are providing me, guys.

I apologize to Mick, if I was a little bit blurried. I just wanted to say that there is no gap between the values in each row (the "|" I insterted above was solely aimed at detecting the different paired groups).

Also, I have a total of 999 rows (999 IDs), each row having 14 groups (the segments), each group having 133 observations (so a total of 14x13=1862 values per row), so the total matrix in the main spreadsheet is 999x1862.

The final matrix should be a 132867x14 matrix (where 133x999=132867)

using the code kindly provided me by Fluff, but instead of 1862 inserting 7000, it is possible to derive the correct transposition for (only) the first ID (all the others are not displayed. The values for the second ID are displayed but with missing values).

I think that just a few arrangements to the Fluff's code are necessary to obtain the correct macro. I have been trying some codes but still don't get it :/

I apologize for bothering you with this, just it is driving me mad!