Transpose VBA Excel Macro based on condition - excel

Question

I am trying to copy & transpose values from one Sheet to another Sheet based on a condition, only transpose the first 4 lines looping in large range.
From this:
To this :
I've found a transpose macro and adapt it but I couldn't apply the condition.
Sub Test()
Set rng = Range("B5", Range("B5").End(xlDown))
Sheets("Example #2").Range(rng).Value = WorksheetFunction.Transpose()
EndSub
Anyone can guide me? Any help would be greatly appreciated!

Answer 1

Please, test the next code. It uses arrays, works in memory and will be much faster than copying. This can be easier observed on a large range:
Sub CopyTranspose4rows()
Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrSl, i As Long
Set sh1 = ActiveSheet 'use here the sheet you need to copy from
Set sh2 = sh1.Next 'use here what sheet you need to paste
lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).row 'last row sh1
arr = sh1.Range("B5:B" & lastR).Value 'put the range in an array for fast iteration
For i = 1 To UBound(arr) Step 4 'iterate from four to four
With Application
'create a slice array
arrSl = .Transpose(.Index(arr, Evaluate("row(" & i & ":" & i + 4 & ")"), 1))
End With
'drop the slice array content in the second sheet
sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1).Resize(1, 4).Value = arrSl
Next i
sh2.Activate 'activate the sheet where pasted
End Sub

Answer 2

#FaneDuru's array solution is more elegant, but here's another alternative. You would need to replace the sheet names and the starting cell numbers.
Sub TestTranspose()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LR1 As Long
Dim x As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LR1 = sht1.Cells(Rows.Count, 2).End(xlUp).Row
y = 1
For x = 1 To LR Step 4
sht1.Range(sht1.Cells(x, 2), sht1.Cells(x + 3, 2)).Copy
sht2.Cells(y, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
y = y + 1
Next x
End Sub

Answer 3

With this code you can have different number of answers per question.
Sub Tranpose_Questions()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim transRng As Range ' range to transpose
Dim dstRng As Range: Set dstRng = ActiveSheet.Range("C1") ' destination cell
' Value find
fnd = "Question"
Set myRange = ActiveSheet.Range("A1", Range("A1").End(xlDown))
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
' Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo errHandler
End If
Set rng = FoundCell
' Loop
Do Until FoundCell Is Nothing
' Find next cell
Set FoundCell = myRange.FindNext(after:=FoundCell)
Debug.Print rng.Address, FoundCell.Address
' Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then
Set transRng = Range(rng, rng.End(xlDown))
If rng.Offset(1, 0) <> "" Then
transRng.Select: transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Exit Do
End If
' Transpose
Set transRng = rng.Resize(FoundCell.Row - rng.Row, 1)
transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
' update rng position
Set rng = FoundCell
' update destination range
Set dstRng = dstRng.Offset(1, 0)
Loop
Exit Sub
' Error Handler
errHandler:
MsgBox "No 'Question' found!"
End Sub