Excel VBA 为数组范围分配单元格地址并合并两个宏的咨询

方案1：合并为单宏（最简便） #

直接把两段逻辑整合，省去传参步骤，同时修复了原代码的语法错误和边界处理问题，代码如下：

Sub FindDateAndNames()
    Dim R As Range
    Dim cell As Range
    Dim strNames() As String
    Dim n As Integer, i As Integer, arrIndex As Integer
    
    ' 第一步：查找首行中当日日期所在单元格
    For Each cell In ActiveSheet.Range("A1:IV1")
        If cell.Value = Date Then ' 替换原有[Today()]写法，兼容性更强
            Set R = cell
            Exit For ' 找到后直接退出循环，提升运行效率
        End If
    Next
    
    ' 容错处理：未找到当日日期时直接提示退出
    If R Is Nothing Then
        MsgBox "未在首行找到当日日期", vbExclamation
        Exit Sub
    End If
    
    ' 第二步：从当日日期列的第二行开始向下搜索匹配值
    n = Range(R.Offset(1, 0), R.Offset(1, 0).End(xlDown)).Rows.Count
    ReDim strNames(n - 1) ' 修正原代码数组下标越界问题
    arrIndex = 0 ' 单独设置数组索引，避免无匹配时空值占位
    
    For i = 0 To n - 1
        If R.Offset(i + 1, 0).Value = "HA (F)" Or R.Offset(i + 1, 0).Value = "HA (H)" Then
            strNames(arrIndex) = R.Offset(i + 1, -8).Value & "  " & R.Offset(i + 1, 0).Value
            arrIndex = arrIndex + 1
        End If
    Next i
    
    ' 仅输出非空匹配结果
    ReDim Preserve strNames(arrIndex - 1)
    MsgBox Join(strNames, vbCrLf)
End Sub

方案2：保留双宏+参数传递 #

如果需要保留两个宏的独立调用能力，可以给FindNames增加Range类型的入参，由FindDate找到目标单元格后传入即可：

1. 修改FindNames为带参数的子过程：

Sub FindNames(startRng As Range) ' 新增入参：搜索起始单元格
    Dim strNames() As String
    Dim n As Integer, i As Integer, arrIndex As Integer
    
    n = Range(startRng, startRng.End(xlDown)).Rows.Count
    ReDim strNames(n - 1)
    arrIndex = 0
    
    For i = 0 To n - 1
        If startRng.Offset(i, 0).Value = "HA (F)" Or startRng.Offset(i, 0).Value = "HA (H)" Then
            strNames(arrIndex) = startRng.Offset(i, -8).Value & "  " & startRng.Offset(i, 0).Value
            arrIndex = arrIndex + 1
        End If
    Next i
    
    ReDim Preserve strNames(arrIndex - 1)
    MsgBox Join(strNames, vbCrLf)
End Sub

2. 修改FindDate，找到日期后调用FindNames并传入起始位置：

Sub FindDate()
    Dim R As Range
    Dim cell As Range
    
    For Each cell In ActiveSheet.Range("A1:IV1")
        If cell.Value = Date Then
            Set R = cell
            Exit For
        End If
    Next
    
    If R Is Nothing Then
        MsgBox "未在首行找到当日日期", vbExclamation
        Exit Sub
    End If
    
    ' 传入当日列第二行作为搜索起点，对应原代码I2的逻辑
    Call FindNames(R.Offset(1, 0))
End Sub

原代码优化点说明 #

• 替换[Today()]为VBA内置函数Date，避免表格公式引用的兼容性问题
• 增加未找到当日日期的容错判断，避免空对象报错
• 优化数组索引逻辑，避免匹配项过少时数组出现空值
• 修复原代码缺少右括号、If拼写错误的语法问题

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