Excel VBA技术问询：查找指定日期列后统计对应水果关联姓名

问题分析 #

你步骤2的代码报错主要有两个核心原因：

• 遍历整列wks.Columns(colNum)会处理工作表全部1048576行，不仅效率极低，还容易因空单元格、格式冲突触发错误；
• 日期匹配时直接用字符串"05/12/2022"对比，若单元格存储的是原生Date类型而非字符串，会导致匹配失败，后续colNum保持初始值0，执行遍历代码必然报错。

修正后的完整代码 #

Public Sub MyVBA()
    Dim c As Range
    Dim colNum As Integer
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim targetDate As Date
    Dim lastRow As Long
    Dim appleCount As Integer, pearCount As Integer
    Dim appleNames() As String, pearNames() As String
    Dim appleIndex As Integer, pearIndex As Integer
    Dim nameCol As Integer ' 绿色列的列号，根据你的实际表格修改
    
    ' 1. 用Date类型定义目标日期，避免字符串匹配问题
    targetDate = CDate("05/12/2022") ' 或用DateSerial(2022, 12, 5)更严谨
    
    ' 绑定目标工作簿和工作表
    Set wkb = Excel.Workbooks("MyOtherWorkbook.xlsx")
    Set wks = wkb.Worksheets("SheetInWorkbook")
    
    ' 2. 查找目标日期所在列
    colNum = 0 ' 初始化，未找到日期时终止后续代码
    For Each c In wks.Range("1:1")
        ' 先判断单元格是否为日期类型，再对比值
        If IsDate(c.Value) And c.Value = targetDate Then
            colNum = c.Column
            Exit For ' 找到后立即退出循环，提升效率
        End If
    Next c
    
    ' 未找到日期列的容错处理
    If colNum = 0 Then
        MsgBox "未找到目标日期对应的列"
        Exit Sub
    End If
    
    ' 定义绿色列（姓名列）的列号，根据你的表格实际位置修改
    nameCol = 2 ' 示例：假设姓名在第2列（B列）
    
    ' 获取数据最后一行，仅遍历有效数据范围
    lastRow = wks.Cells(wks.Rows.Count, colNum).End(xlUp).Row
    
    ' 初始化计数器与数组索引
    appleCount = 0
    pearCount = 0
    appleIndex = 0
    pearIndex = 0
    
    ' 3. 遍历数据行，统计次数并收集对应姓名
    For Each c In wks.Range(wks.Cells(2, colNum), wks.Cells(lastRow, colNum))
        If c.Value <> "" Then
            Select Case c.Value
                Case "Apple"
                    appleCount = appleCount + 1
                    appleIndex = appleIndex + 1
                    ReDim Preserve appleNames(1 To appleIndex)
                    appleNames(appleIndex) = wks.Cells(c.Row, nameCol).Value
                Case "Pear"
                    pearCount = pearCount + 1
                    pearIndex = pearIndex + 1
                    ReDim Preserve pearNames(1 To pearIndex)
                    pearNames(pearIndex) = wks.Cells(c.Row, nameCol).Value
            End Select
        End If
    Next c
    
    ' 4. 将数组转为逗号分隔字符串，写入指定单元格（示例写入E1、F1）
    wks.Range("E1").Value = IIf(appleCount > 0, Join(appleNames, ", "), "无Apple记录")
    wks.Range("F1").Value = IIf(pearCount > 0, Join(pearNames, ", "), "无Pear记录")
    
    ' 可选：弹出统计结果提示
    MsgBox "统计完成：" & vbCrLf & "Apple出现次数：" & appleCount & vbCrLf & "Pear出现次数：" & pearCount
End Sub

关键优化说明 #

• 日期匹配逻辑：改用Date类型对比，彻底避免字符串与单元格日期格式不兼容的问题；
• 范围精准控制：通过lastRow锁定有效数据行，避免遍历大量空行；
• 容错处理：添加未找到日期列的判断，防止后续代码崩溃；
• 动态数组使用：用ReDim Preserve动态扩展数组，灵活收集对应姓名；
• 效率提升：找到目标日期后立即终止循环，减少不必要的遍历操作。

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