使用VBA在Excel列区域粘贴数组：现有代码问题排查与修正

开发一个VBA子过程，将数组数据无循环粘贴至Excel工作表的单元格区域。

build_date_array与populate_date_array函数配合可生成并存储日期数组，paste_array子过程调用这两个函数后尝试将数据粘贴至名为“test”的工作表，但当前代码仅错误粘贴数组的首个元素。

' build timeline data storage array
Function build_date_array(length As Integer) As Variant
    ' declare array variable
    Dim eNumStorage() As String ' initial storage array to take values
    ' dimension the array
    ReDim eNumStorage(1 To length)
    ' set empty array to variable to pass back to module
    build_date_array = eNumStorage
End Function

' Populate a date array
Function populate_date_array(dimed_array As Variant, start As Variant) As Variant
    Dim i As Long
    ' iterate through dimension empty array to populate it with data
    For i = LBound(dimed_array) To UBound(dimed_array)
        If i = LBound(dimed_array) Then
            ' first element of array needs to be the desired start
            dimed_array(i) = Format(WorksheetFunction.EDate(start, 0), "MM/DD/YYYY")
        Else
            ' kick in function for 2nd element to end of array
            dimed_array(i) = Format(WorksheetFunction.EDate(start, i - 1), "MM/DD/YYYY")
        End If
    Next i
    populate_date_array = dimed_array
End Function

Sub paste_array()
    Dim wb As Workbook, sh As Worksheet, date_array As Variant, horizon As Integer
    Set wb = ActiveWorkbook '  instance of workbook
    Set sh = wb.Sheets("test") ' instance of sheet
    horizon = 5 ' time increment in months
    date_array = build_date_array(horizon) ' build empty array
    date_array = populate_date_array(date_array, "10/01/2024")  ' populate array
    LastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row + 1 ' get last row
    'sh.Range("A2").Resize(UBound(date_array), 1).Value = date_array
    sh.Range(sh.Cells(LastRow, 1), sh.Cells(UBound(date_array), 1)).Value = date_array
End Sub

代码与输出分屏视图 #

当前代码仅粘贴首个元素的核心原因有两个：

• 生成的是一维横向数组，直接赋值给纵向单元格区域时，Excel只会填充第一个单元格
• 粘贴范围计算错误：sh.Cells(LastRow, 1), sh.Cells(UBound(date_array), 1)的结束行是UBound(date_array)（即5），如果LastRow大于5，范围会反向，导致赋值异常

修正后的paste_array子过程 #

Sub paste_array()
    Dim wb As Workbook, sh As Worksheet, date_array As Variant, horizon As Integer
    Dim LastRow As Long ' 显式声明变量类型，避免隐式类型错误

    Set wb = ActiveWorkbook
    Set sh = wb.Sheets("test")

    horizon = 5
    date_array = build_date_array(horizon)
    date_array = populate_date_array(date_array, "10/01/2024")

    LastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row + 1

    ' 转置一维数组为纵向，适配单元格列区域
    sh.Cells(LastRow, 1).Resize(UBound(date_array), 1).Value = Application.Transpose(date_array)
End Sub

额外优化方案 #

可以直接在build_date_array中生成二维纵向数组，避免后续转置操作：

Function build_date_array(length As Integer) As Variant
    ' 生成二维数组（行数为length，列数为1）
    Dim eNumStorage() As String
    ReDim eNumStorage(1 To length, 1 To 1)
    build_date_array = eNumStorage
End Function

此时paste_array中无需转置，直接赋值即可：

sh.Cells(LastRow, 1).Resize(UBound(date_array), 1).Value = date_array

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