[代码优化]最接近值查询返回，类似于函数FREQUENCY套路

lizhipei78

有时候我们在查询匹配的时候，会遇到近似查找，且是最接近那个数，在Excel函数中，我们一般会用到=LOOKUP(1,0/FREQUENCY(0,ABS(A$2:A$6-E2)),B$2:B$6)这类的套路。但是在VBA中是怎么实现的呢？我下午想了一下，是能实现了，但是觉得应该能优化，希望大佬看一下。


如图所示，A、B两列是对照表，根据对照表，我们要求最接近的评分F列
我自己写了以下的代码

大家看看能不能优化一下，如果是sheet2中的多条件，又如何写代码？

sheet2这种我不会了

查找区间最接近的值.rar (20.33 KB, 下载次数: 2)

2023-2-7 19:07 上传

点击文件名下载附件

liulang0808

Sub 最接近的值查询()
    Dim Arr, Brr, Temp, K
    Arr = Range("A1").CurrentRegion
    [F2:F6] = ""
    Brr = Range("D1").CurrentRegion
    ReDim Crr(UBound(Arr) * UBound(Brr))
    For i = 2 To UBound(Brr)
        x = Arr(2, 2)
        y = Abs(Arr(2, 1) - Brr(i, 2))
        For j = 3 To UBound(Arr)
            If Abs(Arr(j, 1) - Brr(i, 2)) < y Then
                y = Abs(Arr(j, 1) - Brr(i, 2))
                x = Arr(j, 2)
            End If
        Next
        Brr(i, 3) = x
    Next
    Range("D1").Resize(UBound(Brr), 3) = Brr
End Sub

liulang0808

供参考。。。。。

lizhipei78

liulang0808 发表于 2023-2-7 18:58
供参考。。。。。

非常感谢版主大大的指教，这个比我那个简单一点，像sheet2那种加了品名、规格这种多条件的又怎么弄呢？平时的话应该是这种多条件的正常
我更新了附件及附图，麻烦版主再指点一下，谢谢。

lizhipei78

对于sheet2的多条件查询，参考了版主的代码，不知道是否正确

1. Sub 最接近的值查询()
   
2.     Sheet2.Activate
   
3.     Dim Arr, Brr, Str1$, Str2$, x, y
   
4.     Arr = Range("A1").CurrentRegion
   
5.     [I2:I10] = ""
   
6.     Brr = Range("F1").CurrentRegion
   
7.     For i = 2 To UBound(Brr)
   
8.         x = Arr(2, 4)
   
9.         y = Abs(Arr(2, 3) - Brr(i, 3))
   
10.         For j = 3 To UBound(Arr)
    
11.             Str1 = Brr(i, 1) & Brr(i, 2)
    
12.             Str2 = Arr(j, 1) & Arr(j, 2)
    
13.             If Str1 = Str2 Then
    
14.                 If Abs(Arr(j, 3) - Brr(i, 3)) < y Then
    
15.                     y = Abs(Arr(j, 3) - Brr(i, 3))
    
16.                     x = Arr(j, 4)
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.         Brr(i, 4) = x
    
21.     Next
    
22.     Range("F1").Resize(UBound(Brr), 4) = Brr
    
23. End Sub

复制代码

lizhipei78

针对于sheet2，完善了一下代码，发觉有点啰嗦，看哪个大神能优化一下



Sub 最接近的值查询()
    Sheet2.Activate
    Dim Arr, Brr, Str1$, Str2$, x, y
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    Arr = Range("A1").CurrentRegion
    [I2:I10] = ""
    Brr = Range("F1").CurrentRegion
    For i = 2 To UBound(Brr)
        For j = 2 To UBound(Arr)
            Str1 = Brr(i, 1) & Brr(i, 2)
            Str2 = Arr(j, 1) & Arr(j, 2)
            If Str1 = Str2 Then
                dic(Str1) = dic(Str1) + 1
                If dic(Str1) = 1 Then
                    x = Arr(j, 4)
                    y = Abs(Arr(j, 3) - Brr(i, 3))
                End If
                If Abs(Brr(i, 3) - Arr(j, 3)) < y Then
                    y = Abs(Arr(j, 3) - Brr(i, 3))
                    x = Arr(j, 4)
                End If
            End If
        Next
        Brr(i, 4) = x
        x = Empty
    Next
    Range("F1").Resize(UBound(Brr), 4) = Brr
End Sub

准提部林

介于中間均等...取哪個?
日期早于最小日期, 怎取?

lizhipei78

准提部林 发表于 2023-2-7 22:46
介于中間均等...取哪個?
日期早于最小日期, 怎取?

这个还没有考虑那么多，先按照绝对值最小的来就好了

lizhipei78

再写了一个sheet2的代码