VBA Transpose every 4th row, loop until empty column

[crc234]

Hi there!

I'm new to VBA and am trying to figure out how to make transposing more efficient. I have a sample data set below that I need to transpose (to sheet 2) every 4th row on the first column into a single row, and when that hits an empty cell I need it to loop to the next column, do the same, until it hits an empty column. The issue is this data can get quite long both horizontally and vertically.

I really appreciate if anyone can help out! Thank you so much!



Original Data:







PKO
SJL
PKO
SJL



0.512
0.41
145
85.4



0.47
0.514
158
93.6



0.377
0.51
135
92.5



0.492
0.521
142
98.9



2.99
1.57
180
110



2.56
1.82
181
110



1.84
1.7
146
111



2.01
1.8
151
113



Expected result:



PKO







0.512
0.47
0.377
0.492



2.99
2.56
1.84
2.01



SJL









0.41
0.514
0.51
0.521



1.57
1.82
1.7
1.8





PKO







145
158
135
142



180
181
146
151



SJL



85.4
93.6
92.5
98.9



110
110
111
113

[Trebor76]

Hi crc234,

Welcome to the forum!!

Try this:


Option Explicit

Sub Macro1()
Dim lngMyCol As Long
Dim lngMyRow As Long
Dim lngPasteRow As Long
Dim wsSource As Worksheet
Dim wsOutput As Worksheet

Application.ScreenUpdating = False

Set wsSource = Sheets("Sheet1") 'Sheet name for the raw data. Change to suit, if necessary.
Set wsOutput = Sheets("Sheet2") 'Sheet name for the raw data. Change to suit, if necessary.

For lngMyCol = 1 To wsSource.Cells(1, Columns.Count).End(xlToLeft).Column
For lngMyRow = 2 To wsSource.Cells(Rows.Count, lngMyCol).End(xlUp).Row Step 4

On Error Resume Next 'Account for there being no data on the 'wsOutput' sheet
lngPasteRow = wsOutput.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
If lngPasteRow = 0 Then
lngPasteRow = 1
End If
On Error GoTo 0

If lngMyRow = 2 Then
wsOutput.Range("A" & lngPasteRow).Value = wsSource.Cells(1, lngMyCol).Value
End If

Range(wsSource.Cells(lngMyRow, lngMyCol), wsSource.Cells(lngMyRow + 3, lngMyCol)).Copy
wsOutput.Range("B" & lngPasteRow).PasteSpecial , Transpose:=True

Next lngMyRow
Next lngMyCol

With Application
.CutCopyMode = False
.ScreenUpdating = False
End With

MsgBox "Data has now been transposed from sheet """ & wsSource.Name & """ to sheet """ & wsOutput.Name & """.", vbInformation

Set wsSource = Nothing
Set wsOutput = Nothing

End Sub

Regards,

Robert