SarahDetroja
New Member
- Joined
- May 13, 2020
- Messages
- 18
- Office Version
- 2013
- Platform
- Windows
Give this version a try.Can we do something about it?
Sub Rearrange_v3()
Dim a As Variant, b As Variant, FCols As Variant
Dim i As Long, j As Long, k As Long, UBFC As Long
Const NumCols As Long = 6 'Total number of data columns
Const FixedCols As String = "1 2 5 6" 'Columns A, B, E F (Non Question/Answer columns)
Const QnCol As Long = 3 'Column C (Question column)
Const AnswerCol As Long = 4 'Column D (Answer column)
Const NumQns As Long = 10 'Number of questions
a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, NumCols).Value
FCols = Split(FixedCols)
UBFC = UBound(FCols)
ReDim b(1 To UBound(a) / NumQns, 0 To UBFC + 1 + NumQns)
For i = 2 To UBound(a) Step NumQns
k = k + 1
For j = 0 To UBFC
b(k, j) = a(i, FCols(j))
Next j
For j = UBFC + 1 To UBFC + NumQns
b(k, j) = a(i + j - UBFC - 1, AnswerCol)
Next j
Next i
With Range("Z1") '<- Z1 is top-left cell of results area
.Offset(1).Resize(k, UBound(b, 2)).Value = b
For j = 0 To UBFC
.Offset(0, j).Value = a(1, FCols(j))
Next j
For i = 1 To NumQns
.Offset(0, UBFC + i).Value = a(1 + i, QnCol)
Next i
.CurrentRegion.Columns.AutoFit
End With
End Sub
Hi Peter,Give this version a try.
VBA Code:Sub Rearrange_v3() Dim a As Variant, b As Variant, FCols As Variant Dim i As Long, j As Long, k As Long, UBFC As Long Const NumCols As Long = 6 'Total number of data columns Const FixedCols As String = "1 2 5 6" 'Columns A, B, E F (Non Question/Answer columns) Const QnCol As Long = 3 'Column C (Question column) Const AnswerCol As Long = 4 'Column D (Answer column) Const NumQns As Long = 10 'Number of questions a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, NumCols).Value FCols = Split(FixedCols) UBFC = UBound(FCols) ReDim b(1 To UBound(a) / NumQns, 0 To UBFC + 1 + NumQns) For i = 2 To UBound(a) Step NumQns k = k + 1 For j = 0 To UBFC b(k, j) = a(i, FCols(j)) Next j For j = UBFC + 1 To UBFC + NumQns b(k, j) = a(i + j - UBFC - 1, AnswerCol) Next j Next i With Range("Z1") '<- Z1 is top-left cell of results area .Offset(1).Resize(k, UBound(b, 2)).Value = b For j = 0 To UBFC .Offset(0, j).Value = a(1, FCols(j)) Next j For i = 1 To NumQns .Offset(0, UBFC + i).Value = a(1 + i, QnCol) Next i .CurrentRegion.Columns.AutoFit End With End Sub