VBA Transpose Cells in a range

[decadence]

Hi, Is it possible to transpose a group of cells then move to the next group of cells, Can someone help with tis please

Example:

From This

This1	This2
This3	This4
This5	This6
That1	That2
That3	That4
That5	That6
Something1	Something2
Something3	Something4
Something5	Something6
Nothing1	Nothing2
Nothing3	Nothing4
Nothing5	Nothing6

<tbody>
</tbody>

To This

This1	This2	This3	This4	Ths5	This6
That1	That2	That3	That4	That5	That6
Something1	Something2	Something3	Something4	Something5	Something6
Nothing1	Nothing2	Nothing3	Nothing4	Nothing5	Nothing6

<tbody>
</tbody>

 

[Joe4]

Are there always exactly 6 items for each grouping?
If not, are the names to move to the line always EXACTLY the same, or do they just contain a similar prefix?
If they are not exactly the same, please provide some real examples, so we can see exactly what this data we are working with looks like, so we can ensure that we groups them properly.

 

[decadence]

The original data will always be in columns C and D but will be varied in number of rows, yes it will always be in groups of 6 however the data is varied by numbers and text in each cell.

Essentially what I am looking to do is use cell value rather than specific text but want to put the first 6 cells c1,d1,c2,d2,c3,d3 from c1 to h1 then move to the next 6 cells c4,d4,c5,d5,c6,d6 and put those cells on the next row from c2 to h2 and so forth

 

[Joe4]

Try this (note it will take the data from one sheet and paste it to another, so be sure to update the sheet names at the top of the code to match what you have):

Sub MyTranspose()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lr As Long
    Dim r As Long
    Dim nr As Long
    Dim i As Long
    
'   Set source worksheet
    Set ws1 = Sheets("Sheet1")
'   Set destination worksheet
    Set ws2 = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    
'   Find last row on source sheet with an entry in column C
    lr = ws1.Cells(Rows.Count, "C").End(xlUp).Row
    
'   Loop through all rows
    For r = 1 To lr Step 3
'       Calculate row on destination sheet to paste to
        nr = Int(r / 3) + 1
'       Copy over first three rows of data
        For i = 0 To 2
            ws1.Range(Cells(r + i, "C"), Cells(r + i, "D")).Copy ws2.Cells(nr, (i * 2) + 3)
        Next i
    Next r
    
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
    
End Sub

 

[decadence]

Hi Joe4 This works perfectly, Thank you

 

[Joe4]

You are welcome.