VBA中基于多条件在二维数组实现日期精确/近似匹配

实现思路 #

1. 从数组中筛选出Column1等于指定值的所有记录，提取对应日期（Column3）及需要返回的目标列数据（示例以Column2为例，可按需调整）
2. 对筛选后的日期集合做升序排序，确保能准确定位最近的前序日期
3. 遍历筛选后的日期：优先匹配精确日期；若无精确匹配，则找出最大的、小于目标日期的记录

完整代码示例 #

Sub FindApproximateDateInArray()
    Dim TBL As ListObject
    Set TBL = Sheets("sheet1").ListObjects("Table1")
    Dim DirArray As Variant
    DirArray = TBL.DataBodyRange
    
    ' 定义匹配参数：按需修改类型和值
    Dim targetCol1Value As String ' 若Column1是数字类型，改为Double/Integer
    targetCol1Value = "你的指定值"
    Dim targetDate As Date
    targetDate = DateSerial(2024, 5, 20) ' 替换为实际目标日期
    
    ' 存储筛选后的日期与对应数据
    Dim filteredDates As Collection
    Dim filteredData As Collection
    Set filteredDates = New Collection
    Set filteredData = New Collection
    
    ' 第一步：筛选Column1匹配的记录
    Dim i As Long
    For i = LBound(DirArray, 1) To UBound(DirArray, 1)
        If DirArray(i, 1) = targetCol1Value Then
            filteredDates.Add DirArray(i, 3) ' 存入Column3的日期
            filteredData.Add DirArray(i, 2) ' 存入需要返回的列（示例为Column2）
        End If
    Next i
    
    ' 处理无匹配的情况
    If filteredDates.Count = 0 Then
        UserForm1.TextBox1.Value = "未找到Column1匹配的记录"
        Exit Sub
    End If
    
    ' 第二步：转数组并排序（同步日期和对应数据）
    Dim datesArr() As Date
    Dim dataArr() As Variant
    ReDim datesArr(1 To filteredDates.Count)
    ReDim dataArr(1 To filteredData.Count)
    
    For i = 1 To filteredDates.Count
        datesArr(i) = filteredDates(i)
        dataArr(i) = filteredData(i)
    Next i
    
    ' 冒泡排序：升序排列日期，同步调整对应数据的顺序
    Dim j As Long
    Dim tempDate As Date
    Dim tempData As Variant
    For i = 1 To UBound(datesArr) - 1
        For j = i + 1 To UBound(datesArr)
            If datesArr(i) > datesArr(j) Then
                tempDate = datesArr(i)
                datesArr(i) = datesArr(j)
                datesArr(j) = tempDate
                
                tempData = dataArr(i)
                dataArr(i) = dataArr(j)
                dataArr(j) = tempData
            End If
        Next j
    Next i
    
    ' 第三步：查找精确匹配或最近前序日期
    Dim resultData As Variant
    Dim foundExact As Boolean
    foundExact = False
    Dim closestDate As Date
    closestDate = DateSerial(1900, 1, 1) ' 初始化为最小日期
    
    For i = 1 To UBound(datesArr)
        If datesArr(i) = targetDate Then
            resultData = dataArr(i)
            foundExact = True
            Exit For
        ElseIf datesArr(i) < targetDate And datesArr(i) > closestDate Then
            closestDate = datesArr(i)
            resultData = dataArr(i)
        End If
    Next i
    
    ' 将结果输出到UserForm文本框
    If foundExact Then
        UserForm1.TextBox1.Value = "精确匹配：" & resultData & "（日期：" & Format(targetDate, "yyyy-mm-dd") & "）"
    Else
        If closestDate <> DateSerial(1900, 1, 1) Then
            UserForm1.TextBox1.Value = "近似匹配：" & resultData & "（最近前序日期：" & Format(closestDate, "yyyy-mm-dd") & "）"
        Else
            UserForm1.TextBox1.Value = "无符合条件的前序日期"
        End If
    End If
End Sub

关键逻辑说明 #

• 高效筛选：通过遍历内存数组完成筛选，避免频繁操作工作表，提升运行速度
• 同步排序：排序日期时同步调整对应数据的顺序，确保日期与目标数据一一对应
• 匹配优先级：优先匹配精确日期，无匹配时动态追踪最大的前序日期，保证结果准确性

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