vba - Excel Transposing Every nth row to every nth column

Been trying to figure this out for a while and every solution I've tried hasn't been terribly successful for what I'm trying.

Basically what I'm trying to do is take every other row in a spreadsheet that could be 3 to 80 columns, and transpose them into new columns next to where they were before, while deleting the now empty rows.

I want to make this:

into this:

I've managed to get a few things working, like copying every other row, and inserting columns, but the part that seems to be evading me is making the colored columns also get copied. And as I mentioned, scaling it from any size of spreadsheet seems to also be the part that gets me the most.

Any good ideas?

Answer

Easiest way to get the colors (and other font characteristics) is to do a Copy process. If this is too slow, we can investigate other options.

I would suggest

• Copy the original data to a new worksheet (so as to preserve your original data)


• Determine the last fixed column -- in your sample it is the column labeled Dilution:


• After the last fixed column +1, insert a new column every other column to the last actual column


• copy the information in the second row of each data set up and to the right one cell (into the now empty column).


• delete all the rows which are blank in column A

---

Option Explicit
Sub Interleave2()
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim LastRow As Long, LastCol As Long
    Dim LastFixedColumn As Long

    Dim I As Long, J As Long, K As Long, L As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")

With wsSrc
    LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByRows, _
             searchdirection:=xlPrevious).Row


    LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByColumns, _
             searchdirection:=xlPrevious).Column

    Set rSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

LastFixedColumn = rSrc.Find(what:="Dilution:", after:=rSrc.Cells(1)).Column

Application.ScreenUpdating = False


wsRes.Cells.Clear
rSrc.Copy wsRes.Cells(1, 1)

For I = LastCol To LastFixedColumn + 2 Step -1
    Cells(1, I).EntireColumn.Insert shift:=xlToRight
Next I

With wsRes
    LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _

             LookIn:=xlFormulas, searchorder:=xlByRows, _
             searchdirection:=xlPrevious).Row

    LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByColumns, _
             searchdirection:=xlPrevious).Column

    Set rRes = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With


For I = 3 To rRes.Rows.Count Step 2
    For J = LastFixedColumn + 1 To rRes.Columns.Count Step 2
        rRes(I, J).Copy rRes(I - 1, J + 1)
    Next J
Next I

With rRes
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    With .EntireColumn
        .ColumnWidth = 255

        .AutoFit
    End With
    .EntireRow.AutoFit
End With

Application.ScreenUpdating = True
End Sub

---