Macro to Insert Rows whilst Transposing Multiple Columns

[scheldor]

Hello

I have been reading this Similar Thread but cannot work out how to alter the solution to solve my problem.

I have a Worksheet which runs columns A through BC with approximately 2,000 rows, here is a shortened version with just 2 rows: Workbook

For each existing row: for each non-blank cell in columns Q, S, U, etc. (i.e. alternate columns from Q through BC) I need to Insert an additional row and copy down the contents of columns A through P. Then I need to transpose the values in columns Q, S, U, etc. (i.e. alternate columns from Q through BB) into column Q and the values in columns R, T, V, etc. (i.e. alternate columns from R through BC) into column R.

This is probably better explained by an example, so I have mocked-up the desired result on the second tab of the Workbook

Many Thanks in advance for any help

 

[ravishankar]

transpose of data means horizontal row becomes vertical column and vice versa. to me the attached workbooks are not clear.
Ravi shankar

 

[Peter_SSs]

There seems to be an anomaly with your data. In the repeated Date & Read columns, which start at column Q and end at column BC, there are 20 Date columns but only 19 Read columns. So I have assumed that the data might actually go to column BD, giving 20 of each.

Try this in a copy of your workbook. This creates a new worksheet with the results.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, c As Long, r As Long, uba2 As Long
  
  With Sheets("Raw")
    a = .Range("A1:BD" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
  End With
  uba2 = UBound(a, 2)
  ReDim b(1 To 20 * UBound(a), 1 To 18)
  For i = 2 To UBound(a)
    For j = 17 To uba2 Step 2
      If Len(a(i, j)) Then
        r = r + 1
        For c = 1 To 16
          b(r, c) = a(i, c)
        Next c
        b(r, 17) = a(i, j): b(r, 18) = a(i, j + 1)
      End If
    Next j
  Next i
  Sheets.Add After:=Sheets("Raw")
  With Sheets(Sheets("Raw").Index + 1)
    .Range("A2").Resize(r, 18).Value = b
    .Range("A1:R1").Value = Sheets("Raw").Range("A1:R1").Value
    .UsedRange.Columns.AutoFit
  End With
End Sub