VBA复制粘贴转置并按分组排列的实现问题求助

问题描述 #

原始数据（以空行分隔不同分组）：

A1 00001
A1 00002

B1 00001
B1 00002

期望转置效果（每组单独转置，保留分组间的空行分隔）：

A1       A1
00001    00002

B1       B1
00001    00002

当前使用的VBA代码会将所有数据连续转置，不符合需求，效果如下：

A1       A1       B1       B1
00001    00002    00001    00002

解决方案代码 #

以下代码可按空行识别分组，逐个完成转置粘贴，保留原分组结构：

Sub TransposeByGroups()
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim srcStartRow As Long
    Dim srcEndRow As Long
    Dim destRow As Long
    Dim groupRange As Range
    
    ' 定义源工作表与目标工作表
    Set srcSheet = ActiveSheet
    Set destSheet = ThisWorkbook.Sheets("POSITION")
    
    ' 初始化目标起始行（D列最后一行的下一行）
    destRow = destSheet.Range("D" & destSheet.Rows.Count).End(xlUp).Row + 1
    srcStartRow = 1
    
    ' 遍历所有分组
    Do While srcStartRow <= srcSheet.Range("A" & srcSheet.Rows.Count).End(xlUp).Row
        ' 定位当前分组的结束行
        srcEndRow = srcSheet.Range("A" & srcStartRow).End(xlDown).Row
        ' 处理分组内无空行的情况，找到真正的分组结束行
        Do While srcSheet.Range("A" & srcEndRow + 1).Value <> "" And srcEndRow + 1 <= srcSheet.UsedRange.Rows.Count
            srcEndRow = srcEndRow + 1
        Loop
        
        ' 选中当前分组的A、B列数据
        Set groupRange = srcSheet.Range("A" & srcStartRow & ":B" & srcEndRow)
        
        ' 转置粘贴到目标区域
        groupRange.Copy
        destSheet.Range("D" & destRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        
        ' 目标行下移2行，预留空行分隔分组
        destRow = destRow + 2
        ' 源起始行跳转到下一组
        srcStartRow = srcEndRow + 2
        
        Application.CutCopyMode = False
    Loop
End Sub

代码说明 #

• 先指定源工作表（当前激活表）和目标工作表（"POSITION"）
• 通过空行识别每个分组的起止范围，避免跨分组处理
• 对单个分组执行转置粘贴操作，确保每组结构独立
• 每次粘贴后下移目标行2行，保留分组间的空行分隔
• 循环处理直到所有分组完成转置

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