Excel VBA多列转置需求：保留首列数据位置的问题

要实现首列数据位置完全保留，其他列数据合并到首列下方形成单列的需求，修改后的VBA代码如下：

Sub MergeKeepFirstCol()
    Dim outArr() As Variant
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 如需指定固定工作表，可改为 ThisWorkbook.Worksheets("你的工作表名")
    
    ' 获取数据区域的最后一列
    Dim lastCol As Long
    lastCol = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    ' 获取首列的最后行号（确保首列所有行都被保留）
    Dim lastRowCol1 As Long
    lastRowCol1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 获取所有数据的最后行号
    Dim lastRowAll As Long
    lastRowAll = ws.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ' 统计其他列的非空单元格数量
    Dim nonEmptyCount As Long
    nonEmptyCount = 0
    Dim i As Long, j As Long
    For i = 1 To lastRowAll
        For j = 2 To lastCol
            If ws.Cells(i, j).Value <> "" Then
                nonEmptyCount = nonEmptyCount + 1
            End If
        Next j
    Next i
    
    ' 初始化输出数组：首列行数 + 其他列非空单元格数
    ReDim outArr(1 To lastRowCol1 + nonEmptyCount, 1 To 1)
    
    ' 填充首列内容，保证原位置不变
    For i = 1 To lastRowCol1
        outArr(i, 1) = ws.Cells(i, 1).Value
    Next i
    
    ' 填充其他列的非空数据到数组末尾
    Dim idx As Long
    idx = lastRowCol1 + 1
    For i = 1 To lastRowAll
        For j = 2 To lastCol
            If ws.Cells(i, j).Value <> "" Then
                outArr(idx, 1) = ws.Cells(i, j).Value
                idx = idx + 1
            End If
        Next j
    Next i
    
    ' 将数组写入目标列（最后一列的下一列）
    ws.Cells(1, lastCol + 1).Resize(UBound(outArr, 1), 1).Value = outArr
End Sub

代码说明 #

• 首列位置锁定：先把首列的所有内容（包括空白行）完整复制到输出数组的前半部分，确保原首列第9行的pink仍在结果列的第9行。
• 其他列数据追加：遍历第2列到最后一列的所有非空单元格，将它们依次追加到输出数组的后半部分，放在首列内容的下方。
• 工作表适配：代码默认使用当前激活工作表，如需固定工作表，可修改Set ws = ActiveSheet为具体工作表名称，避免切换工作表导致错误。

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