如何用VBA在Excel中正确堆叠列？现有脚本结果不符预期

问题说明 #

使用网上找到的VBA脚本堆叠Excel列时，出现横线集中在堆叠内容底部的情况，与预期的每列横线跟随对应列内容的结果不符。

原脚本（存在问题） #

Sub ConvertRangeToColumn()
'UpdatebyExtendoffice
    Dim Range1 As Range, Range2 As Range, Rng As Range
    Dim rowIndex As Integer
    xTitleId = "KutoolsforExcel"
    Set Range1 = Application.Selection
    Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
    Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
    rowIndex = 0
    Application.ScreenUpdating = False
    For Each Rng In Range1.Rows
        Rng.Copy
        Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        rowIndex = rowIndex + Rng.Columns.Count
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

修正后的脚本 #

原脚本通过按行转置实现堆叠，会打乱列内的内容结构。以下脚本改为按列遍历复制，保留每列的原有结构（包括横线位置）：

Sub StackColumnsWithCorrectLinePosition()
    Dim sourceRange As Range, targetStartCell As Range
    Dim singleCol As Range
    Dim currentOffsetRow As Long
    
    ' 选择源数据区域
    Set sourceRange = Application.InputBox("请选择需要堆叠的源数据区域:", Type:=8)
    ' 选择堆叠后的起始单元格
    Set targetStartCell = Application.InputBox("请选择堆叠结果的起始单元格:", Type:=8)
    
    currentOffsetRow = 0
    Application.ScreenUpdating = False
    
    ' 遍历每一列，将整列内容复制到目标区域
    For Each singleCol In sourceRange.Columns
        singleCol.Copy targetStartCell.Offset(currentOffsetRow, 0)
        currentOffsetRow = currentOffsetRow + singleCol.Rows.Count
    Next singleCol
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

修正逻辑 #

• 原脚本按行遍历并转置，导致每行的所有列内容被竖排，所有横线（通常是每行最后一列）被集中到堆叠末尾。
• 修正后的脚本直接遍历每一列，将整列内容完整复制到目标区域的下方，确保每列的横线保留在对应列内容的底部，最终堆叠结果符合预期。

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