字典法匹配求助

Dragonfly7995

字典法匹配求助，写了一段代码，无法执行，请指教，谢谢

opel-wong

按你的思路，修改了一下，

1. Sub 匹配报价()
   
2.     Dim arr, brr, d As Object, ii&, t$
   
3.     Set d = CreateObject("Scripting.dictionary")
   
4.     arr = Sheets("报价单").UsedRange.Value
   
5.     For ii = 4 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2) Step 6
   
7.             s = arr(ii, j)
   
8.             d(s) = arr(ii, j + 4)
   
9.         Next
   
10.     Next
    
11.     ' ----------
    
12.     brr = Sheets("汇总").UsedRange.Value
    
13.     For ii = 4 To UBound(brr)
    
14.         t = brr(ii, 3)
    
15.         If d.exists(t) Then brr(ii, 6) = d(t)
    
16.     Next
    
17.     Sheets("汇总").UsedRange.Value = brr
    
18.     Set d = Nothing

复制代码

半百

Sub 匹配报价()
Dim arr, brr   ' As Range
    Set d = CreateObject("Scripting.dictionary")
   Sheets("报价单").Select
   arr = Sheets("报价单").UsedRange 'CurrentRegion
            For ii = 4 To UBound(arr)
                For j = 1 To UBound(arr, 2) Step 6
                    s = arr(ii, j + 1)
                    d(s) = arr(ii, j + 4)
                Next
            Next
   
     Sheets("汇总").Select
brr = Sheets("汇总").UsedRange 'CurrentRegion
For ii = 4 To UBound(brr)
t = brr(ii, 3)
If d.exists(t) Then
brr(ii, 6) = d(t) '.Key
   End If
    Next
  Sheets("汇总").UsedRange = brr
End Sub

那年的坏人

记得 currentregion  是单元格属性吧 ~ 不能直接作用于工作表~

lsc900707

1. Sub 匹配报价()
   
2.     Set d = CreateObject("Scripting.dictionary")
   
3.     With Sheets("报价单")
   
4.         r = .Cells(.Rows.Count, 3).End(3).Row
   
5.         arr = .[a4].Resize(r, 12)
   
6.     End With
   
7.     For i = 1 To UBound(arr)
   
8.         For j = 1 To UBound(arr, 2) Step 6
   
9.             s = arr(i, j + 1)
   
10.             d(s) = arr(i, j + 4)
    
11.         Next
    
12.     Next
    
13.     brr = [a1].CurrentRegion
    
14.     For i = 4 To UBound(brr)
    
15.         If Len(brr(i, 3)) > 0 Then
    
16.             s = brr(i, 3)
    
17.             If d.exists(s) Then brr(i, 6) = d(s)
    
18.         End If
    
19.     Next
    
20.     [a1].CurrentRegion = brr
    
21. End Sub

复制代码

lsc900707

测试参考附件：