☰

Excel 将每第 n 行转置为每第 n 列

tag-icon • tag-icon microsoft-excel vba
Excel 将每第 n 行转置为每第 n 列

我尝试解决这个问题已经有一段时间了，但我尝试过的每一个解决方案都没有取得很大的成功。

基本上，我想要做的是将电子表格中每隔一行（可能有 3 到 80 列）转置到之前所在位置旁边的新列中，同时删除现在的空行。

我想这样做：

前

变成这样：

后

我已经设法完成了一些操作，例如复制每隔一行，插入列，但似乎让我困惑的部分是让彩色列也被复制。正如我提到的，从任何大小的电子表格中缩放它似乎也是最让我头疼的部分。

有什么好主意吗？

答案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

相关内容