[已解决]提取符合二维条件的交叉值

曾予曦

请大师们，帮帮忙！谢谢！详看图或附件

最佳答案

月排行榜 / 总排行榜

云影

2014-6-20 13:17

1. Sub test()
   
2.     Dim arr, ar1, er$(), str$
   
3.     Dim d As Object, x%, y%, k%
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Range("b2:j" & Cells(Rows.Count, 1).End(3).Row)
   
6.     ar1 = Range("m2").CurrentRegion
   
7.     For y = 1 To UBound(arr, 2)
   
8.         For x = 1 To UBound(arr)
   
9.             str = arr(x, 1) & arr(1, y)
   
10.             d(str) = arr(x, y)
    
11.         Next
    
12.     Next
    
13.     For x = 3 To UBound(ar1)
    
14.         st = ar1(x, 3) & ar1(x, 4) & ar1(x, 1) & ar1(x, 2)
    
15.         ar1(x, 6) = d(st)
    
16.     Next
    
17.     Range("m1").Resize(x - 1, 6) = ar1
    
18. End Sub

复制代码

跳转到最佳答案楼层

ghostjiao

云影

1. Sub test()
   
2.     Dim arr, ar1, er$(), str$
   
3.     Dim d As Object, x%, y%, k%
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Range("b2:j" & Cells(Rows.Count, 1).End(3).Row)
   
6.     ar1 = Range("m2").CurrentRegion
   
7.     For y = 1 To UBound(arr, 2)
   
8.         For x = 1 To UBound(arr)
   
9.             str = arr(x, 1) & arr(1, y)
   
10.             d(str) = arr(x, y)
    
11.         Next
    
12.     Next
    
13.     For x = 3 To UBound(ar1)
    
14.         st = ar1(x, 3) & ar1(x, 4) & ar1(x, 1) & ar1(x, 2)
    
15.         ar1(x, 6) = d(st)
    
16.     Next
    
17.     Range("m1").Resize(x - 1, 6) = ar1
    
18. End Sub

复制代码

曾予曦

ghostjiao 发表于 2014-6-20 12:51

OK，谢谢！