哪位老铁帮忙将sub变更成函数，谢谢！

tylerchu

哪位老铁帮忙将sub变更成函数，谢谢！

WANT-T

1. Public Function Dic_Test(Rng As Range)
   
2.     Dim Arr, Brr
   
3.     Dim Dic As Object
   
4.     Dim i, j, m, n As Long
   
5.     Set Rng = Sheets("多条件").Range("L1").CurrentRegion
   
6.     Arr = Rng
   
7.     Set Dic = CreateObject("Scripting.Dictionary")
   
8.     For i = 2 To UBound(Arr)
   
9.         For j = 3 To UBound(Arr, 2)
   
10.             Dic(Arr(i, 1) & Arr(i, 2) & Arr(1, j)) = Arr(i, j)
    
11.         Next j
    
12.     Next i
    
13.     Set Rng = Sheets("多条件").Range("A1").CurrentRegion
    
14.     Brr = Rng
    
15.     For m = 2 To UBound(Brr)
    
16.         For n = 3 To UBound(Brr, 2)
    
17.             Brr(m, n) = Dic(Brr(m, 1) & Brr(m, 2) & Brr(1, n))
    
18.         Next n
    
19.     Next m
    
20.     Dic_Test = Brr
    
21.     Set Dic = Nothing
    
22. End Function

复制代码

longwin

longwin

附件供参考。。。。

quqiyuan

写了两个，仅供参考。。。
一个在其他位置，自动溢出，一个在数据区

quqiyuan

代码如下。。。
Function test(rng As Range, rg As Range)
    Dim Arr, Brr
    Dim Dic As Object
    Dim i, j, m, n As Long
    Arr = rng
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Arr)
        For j = 3 To UBound(Arr, 2)
            Dic(Arr(i, 1) & Arr(i, 2) & Arr(1, j)) = Arr(i, j)
        Next j
    Next i
    Brr = rg
    For m = 2 To UBound(Brr)
        For n = 3 To UBound(Brr, 2)
            Brr(m, n) = Dic(Brr(m, 1) & Brr(m, 2) & Brr(1, n))
        Next n
    Next m
    test = Brr
    Set Dic = Nothing
End Function

Function suju(rng As Range, rg As Range)
    Dim Arr, Brr
    Dim Dic As Object
    Dim i, j, m, n As Long
    Arr = rng
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Arr)
        For j = 3 To UBound(Arr, 2)
            Dic(Arr(i, 1) & Arr(i, 2) & Arr(1, j)) = Arr(i, j)
        Next j
    Next i
    suju = Dic(Cells(rg.Row, 1) & Cells(rg.Row, 2) & Cells(1, rg.Column))
    Set Dic = Nothing
End Function

tylerchu

quqiyuan 发表于 2024-10-8 16:29
代码如下。。。
Function test(rng As Range, rg As Range)
    Dim Arr, Brr

suju可以用，谢谢！

tylerchu

longwin 发表于 2024-10-8 15:56
附件供参考。。。。

可用，谢谢！

tylerchu

quqiyuan 发表于 2024-10-8 16:29
代码如下。。。
Function test(rng As Range, rg As Range)
    Dim Arr, Brr

test也可以用，但是在我的场景里面不方便，谢谢！