如何使用VBA动态提取多列Date数据并堆叠粘贴到同一列？

修改后可动态适配的VBA代码 #

Sub 合并所有日期列()
    Dim r As Long, i As Long, j As Long
    Dim arr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    
    With Worksheets("sheet1")
        ' 遍历第一行所有已使用列，自动识别Date表头的列
        For j = 1 To .UsedRange.Columns.Count
            If Trim(.Cells(1, j).Value) = "Date" Then
                r = .Cells(.Rows.Count, j).End(xlUp).Row
                ' 仅处理表头下有数据的列，避免报错
                If r >= 2 Then
                    arr = .Cells(2, j).Resize(r - 1, 1)
                    For i = 1 To UBound(arr)
                        ' 跳过空单元格，避免空值存入字典
                        If Not IsEmpty(arr(i, 1)) Then
                            d(arr(i, 1)) = Empty
                        End If
                    Next
                End If
            End If
        Next
        
        ' 清空原有结果并输出去重后的日期
        .Range("k2:k" & .Rows.Count).Clear
        If d.Count > 0 Then
            .Range("k2").Resize(d.Count, 1) = Application.Transpose(d.keys)
        End If
    End With
    Set d = Nothing
End Sub

核心优化说明 #

• 移除了硬编码的列号数组，改为遍历工作表第一行所有已使用列，自动匹配表头为Date的列，后续新增基金数据后不需要手动调整代码
• 新增了边界校验逻辑：空列、空单元格的场景下不会报错，稳定性更高

可选调整项 #

• 如果表头不在第1行，将代码中.Cells(1, j).Value的行号1改为你实际的表头行号即可
• 如果需要不区分大小写匹配表头（比如匹配date、DATE都生效），将判断条件改为UCase(Trim(.Cells(1, j).Value)) = "DATE"
• 结果默认输出到K列，修改.Range("k2")的单元格地址即可更换输出位置

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