按日期寻找接近条件的数据填充？

汶誉仔

条件找数填充.rar (10.35 KB, 下载次数: 10)

2024-10-3 14:55 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(2).[E2].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & " " & ar(i, 2)
    Next i
   
    With Worksheets(1)
        ar = .[B2].CurrentRegion.Value
        For i = 2 To UBound(ar)
            If Len(ar(i, 3)) = False Then
                If dic.exists(ar(i, 1)) Then
                    br = Split(dic(ar(i, 1)))
                    For j = 1 To UBound(br)
                        If (ar(i, 2) - br(j)) <= ar(i, 2) * 0.01 Then
                            ar(i, 3) = br(j): Exit For
                        End If
                    Next j
                End If
            End If
        Next i
        .[K2].Resize(UBound(ar), UBound(ar, 2)) = ar
        .Activate
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。

z865593849

汶誉仔

z865593849 发表于 2024-10-3 15:46

接近数列的原有数据要保留

汶誉仔

gwjkkkkk 发表于 2024-10-3 15:30
。。。。。。。。。。

运行结果与例子结果不符，请老师看看条件是否可以更改？

汶誉仔

各位老师，有没有好的解决方案？

ykcbf1100

参与一下，结果在D列。

ykcbf1100

参与一下。。。