Excel транспонирование каждой n-й строки в каждый n-й столбец

Question

Я пытался выяснить это некоторое время, и каждое решение, которое я пробовал, не было очень успешным для того, что я пытаюсь.

По сути, я пытаюсь взять все остальные строки в электронной таблице, которые могут содержать от 3 до 80 столбцов, и перенести их в новые столбцы рядом с тем, где они были раньше, при этом удаляя пустые строки.

Я хочу сделать это:

в это:

Мне удалось заставить работать несколько вещей, таких как копирование каждой второй строки и вставка столбцов, но часть, которая, кажется, уклоняется от меня, заставляет цветные столбцы также копироваться. И, как я уже упоминал, масштабирование из любого размера электронной таблицы, кажется, также та часть, которая привлекает меня больше всего.

Есть хорошие идеи?

Answer 1

Самый простой способ получить цвета (и другие характеристики шрифта) - выполнить процесс Copy . Если это слишком медленно, мы можем исследовать другие варианты.

Я бы предложил

• Скопируйте исходные данные на новый рабочий лист (чтобы сохранить исходные данные)
• Определите последний фиксированный столбец - в вашем примере это столбец с меткой Разбавление:
• После последнего фиксированного столбца +1 вставьте новый столбец через каждый второй столбец в последний фактический столбец
• скопируйте информацию во второй строке каждого набора данных и справа на одну ячейку (в теперь пустой столбец).
• удалить все пустые строки в столбце 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

---