VBA自定义函数返回数组至Excel多单元格仅显示首个值的问题

一、数组公式仅显示首个值的修复 #

• 根本原因：你返回的是(1 To c.Count, 1 To 1)的纵向二维数组，但输入数组公式时错误地仅选中单个单元格后下拉——下拉操作会把数组公式拆分为单个单元格的普通公式，只能取数组第一个元素。
• 正确操作：先选中足够数量的连续纵向单元格（数量不小于去重后的日期总数），再输入公式，最后按Ctrl+Shift+Enter确认数组公式。
• 代码隐患修复：原代码中min(Start_Dates.Value)是错误写法，VBA原生没有处理Range的Min函数，必须替换为WorksheetFunction.Min(Start_Dates.Value)，否则会触发运行时错误。

二、Transpose导致Excel崩溃的修复 #

• 崩溃原因：WorksheetFunction.Transpose对日期类型数组或较大数组存在稳定性问题，易触发内存异常导致Excel崩溃。
• 替代方案：手动实现转置逻辑，不要依赖内置函数：

  ' 仅处理单列转单行的日期数组
  Private Function TransposeDateArray(inputArr() As Date) As Date()
      Dim outputArr() As Date, i As Long
      If UBound(inputArr, 2) <> 1 Then Exit Function
      ReDim outputArr(1 To 1, 1 To UBound(inputArr, 1))
      For i = 1 To UBound(inputArr, 1)
          outputArr(1, i) = inputArr(i, 1)
      Next
      TransposeDateArray = outputArr
  End Function
  

  若需要横向输出数组，在原函数末尾调用此自定义转置函数即可：EVA_Deadlines = TransposeDateArray(dates)

优化后的完整代码 #

Public Function EVA_Deadlines(Start_Dates As Range, Due_Dates As Range) As Date()
    Dim dates() As Date, c As New Collection, r As Range, l As Long
    
    ' 处理空输入范围的边界情况
    If Start_Dates.Cells.Count = 0 Or Due_Dates.Cells.Count = 0 Then
        ReDim dates(1 To 1, 1 To 1)
        EVA_Deadlines = dates
        Exit Function
    End If
    
    ' 修正Min函数调用
    c.Add WorksheetFunction.Min(Start_Dates.Value)
    For Each r In Due_Dates
        ' 跳过空单元格，避免无效值进入集合
        If Not IsEmpty(r.Value) Then
            c.Add getLastDayOfMonth(r.Value)
        End If
    Next
    
    ' 去重处理
    With New clsCollectionHelper
        Set .items = c
        Set c = .removeDuplicates
    End With
    
    ' 生成纵向二维数组（适配纵向选中的单元格）
    ReDim dates(1 To c.Count, 1 To 1)
    For l = 1 To c.Count
        dates(l, 1) = c(l)
    Next
    
    ' 若需要横向输出，注释上面一行，启用下面一行
    ' EVA_Deadlines = TransposeDateArray(dates)
    EVA_Deadlines = dates
End Function

' 自定义转置函数，替代不稳定的内置Transpose
Private Function TransposeDateArray(inputArr() As Date) As Date()
    Dim outputArr() As Date, i As Long
    If UBound(inputArr, 2) <> 1 Then Exit Function
    ReDim outputArr(1 To 1, 1 To UBound(inputArr, 1))
    For i = 1 To UBound(inputArr, 1)
        outputArr(1, i) = inputArr(i, 1)
    Next
    TransposeDateArray = outputArr
End Function

使用步骤 #

1. 选中需要输出结果的连续纵向单元格（数量≥去重后的日期数量）；
2. 输入公式=EVA_Deadlines(你的开始日期范围,你的截止日期范围)；
3. 按下Ctrl+Shift+Enter确认数组公式，所有选中单元格将自动填充对应日期。

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