Excel VBA问题：将A列按空白分隔的垂直数据转置为水平多行

你的现有代码逻辑完全跑偏了——它只是逐个遍历A列单元格，还错误地去查每行的最后一列（原数据每行只有A列有值，这步纯多余），而且没复制就直接调用PasteSpecial，不报错才怪，更别说实现分组转置的需求了。

核心实现思路 #

要实现按空行分组转置，关键是收集一组非空值，遇到空行就把这组值转成一行，具体步骤：

• 遍历A列所有行，把非空单元格的值存到临时数组里
• 碰到空单元格时，把数组转置到目标工作表的新行，然后清空数组继续下一组
• 最后处理最后一组（可能没有结尾的空行）

修正后的VBA代码 #

Sub TransposeGroups()
    ScreenUpdating = False
    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long, i As Long, arrIndex As Long
    Dim tempArr() As Variant
    
    ' 设置源工作表和目标工作表
    Set srcSheet = ActiveSheet
    Set destSheet = ThisWorkbook.Sheets("Sheet2")
    ' 清空目标表原有数据（可选，根据需求调整）
    destSheet.Cells.Clear
    
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
    arrIndex = 0
    
    ' 遍历A列所有行
    For i = 1 To lastRow
        ' 如果当前单元格非空，加入临时数组
        If Trim(srcSheet.Cells(i, "A").Value) <> "" Then
            arrIndex = arrIndex + 1
            ReDim Preserve tempArr(1 To arrIndex)
            tempArr(arrIndex) = srcSheet.Cells(i, "A").Value
        Else
            ' 碰到空单元格，把临时数组转置到目标表
            If arrIndex > 0 Then
                destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, arrIndex).Value = tempArr
                arrIndex = 0
                Erase tempArr
            End If
        End If
    Next i
    
    ' 处理最后一组（如果最后没有空行结尾）
    If arrIndex > 0 Then
        destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, arrIndex).Value = tempArr
    End If
    
    ScreenUpdating = True
    MsgBox "转置完成！"
End Sub

代码关键点说明 #

• 用tempArr临时存储每组的非空值，动态扩展数组大小适配每组4-8个值的随机情况
• 碰到空行就把数组一次性写入目标表，比逐个单元格粘贴效率高得多
• 最后补充处理无空行结尾的分组，避免遗漏数据
• 关闭ScreenUpdating减少屏幕刷新，提升运行速度

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