如何修改VBA代码实现空行分隔的4列可变行区域相邻转置

原有单列转置代码 #

原有代码仅支持单列空行分隔数据的转置，逻辑为识别A列空行作为块边界，逐块转置后纵向排列：

Sub Transpose()

Dim lastrow As Long, i As Long, j As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    iStart = 1
    For i = 1 To lastrow + 1
        If .Range("A" & i).Value = "" Then
            iEnd = i
            j = j + 1
            .Range(.Cells(iStart, 1), .Cells(iEnd, 1)).Copy
            ws.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

核心修改思路 #

• 块边界判断逻辑调整：原逻辑仅判断A列单个单元格是否为空，改为判断当前行A-D列是否全部为空，避免块内单个单元格空值被误判为分隔符；同时增加末尾边界判断，防止最后一个数据块因无末尾空行被遗漏
• 复制范围调整：原逻辑仅复制A列对应行区间，改为复制A-D列的完整行区间，覆盖全部4列源数据
• 粘贴逻辑调整：原逻辑转置后按行纵向逐块排列，改为按列横向逐块粘贴，每次粘贴完成后自动识别下一个空白列作为下一块的起始位置，实现块与块相邻无重叠排列
• 增加连续空行过滤：跳过多个连续空行产生的无效区间，避免生成空的转置结果

修改后完整可运行代码 #

Sub TransposeMultiColumn()
    Dim lastrow As Long, i As Long, iStart As Long, iEnd As Long
    Dim ws As Worksheet
    Dim isBlankRow As Boolean
    Dim nextPasteCol As Long
    
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        ' 新建工作表存储转置结果
        Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
        ' 获取源数据最后一行行号，可根据实际数据列调整统计基准
        lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
        iStart = 1
        nextPasteCol = 1 ' 第一个数据块从A列开始粘贴
        
        For i = 1 To lastrow + 1
            ' 判定块边界：遍历超出数据最大行、或当前行A-D列全为空
            If i > lastrow Then
                isBlankRow = True
            Else
                isBlankRow = Application.WorksheetFunction.CountA(.Range("A" & i & ":D" & i)) = 0
            End If
            
            If isBlankRow Then
                iEnd = i - 1
                ' 过滤连续空行导致的无效数据区间
                If iEnd >= iStart Then
                    ' 复制当前数据块的4列完整内容
                    .Range(.Cells(iStart, 1), .Cells(iEnd, 4)).Copy
                    ' 转置粘贴到目标位置
                    ws.Cells(1, nextPasteCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                    ' 更新下一个块的粘贴起始列
                    nextPasteCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
                End If
                iStart = i + 1
            End If
        Next i
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

使用注意事项 #

• 代码默认读取Sheet1工作表中的源数据，转置结果会自动存放在工作簿末尾新建的工作表中
• 如果后续源数据列数有调整，只需修改空行判断的列范围、复制范围的终止列号两个参数即可快速适配
• 代码自动适配每个数据块的不同行数，不需要提前固定块大小

内容的提问来源于stack exchange，提问作者user19385316