请教：学习字典来匹配关键字，谢谢！

lwx228

学习字典来匹配关键字，谢谢！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a6").CurrentRegion
   
5. ReDim crr(1 To UBound(arr), 1 To 1)
   
6. Application.ScreenUpdating = False
   
7. With Workbooks.Open(ThisWorkbook.Path & "\原数据.xls") '03版
   
8.     brr = .Sheets(1).UsedRange
   
9.     .Close 0
   
10. End With
    
11. For j = 2 To UBound(brr, 2)
    
12.     For i = 3 To UBound(brr)
    
13.         zf = brr(1, j) & "," & brr(i, 1)
    
14.         d(zf) = brr(i, j)
    
15.     Next
    
16. Next
    
17. For i = 1 To UBound(arr)
    
18.     zf = arr(i, 1) & "," & arr(i, 2)
    
19.     crr(i, 1) = d(zf)
    
20. Next
    
21. Range("c6").Resize(UBound(crr)) = crr
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

dsmch

………………

zez

Public Sub zz()
    Dim d
    Set d = CreateObject("Scripting.Dictionary")
    arr = Workbooks("原数据").Sheets("Sheet1").Range("A1:AG30")
    For N = 3 To 30
        For I = 2 To 33
            d(arr(1, I) & arr(N, 1)) = arr(N, I)
            
        Next
    Next
    With Workbooks("匹配").Sheets("Sheet1")
        For N = 6 To 33
            .Cells(N, 3) = d(.Cells(N, 1).Value & .Cells(N, 2).Value)
        Next
    End With
End Sub
因为你的数据都是1，所以没有检验正确性，请自行检验

zax010

Sub zz()
    Dim d, ar, wb As Workbook
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\原数据.xlsm")
    With wb.Sheets(1)
        lr = .[a1048576].End(3).Row
        ar = Range("A1:AG" & lr)
    End With
    wb.Close False
    For j = 2 To UBound(ar, 2)
        For i = 3 To UBound(ar)
            If Not d.exists(ar(1, j) & ar(i, 1)) Then d(ar(1, j) & ar(i, 1)) = ar(i, j)
        Next
    Next
    With Sheet1
        For i = 6 To [a1048576].End(3).Row
            .Cells(i, 3) = d(.Cells(i, 1).Value & .Cells(i, 2).Value)
            If .Cells(i, 3) = "" Then .Cells(i, 3) = 0
        Next
    End With
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>>>>>

学习字典匹配.rar (23.15 KB, 下载次数: 73)

2015-8-1 18:13 上传

点击文件名下载附件

lwx228

谢谢各位老师，看看哪个代码更快

lwx228

将数据调整位置后，自己也能修改代码，{:soso_e100:}
漫长的等待中
Sub zz2()
    Dim d, ar, wb As Workbook
    Set d = CreateObject("Scripting.Dictionary")
     Workbooks("原数据").Activate
    With Sheets(1)
        ar = Range(cells(1,2),cells(Cells(Rows.Count, 2).End(3).Row,Cells(1, Columns.Count).End(xlToLeft).Column))
    End With
    ActiveWindow.ActivateNext
    For j = 2 To UBound(ar, 2)
        For i = 3 To UBound(ar)
            If Not d.exists(ar(1, j) & ar(i, 1)) Then d(ar(1, j) & ar(i, 1)) = ar(i, j)
        Next
    Next
    With Sheet1
        For i = 10 To [a1048576].End(3).Row
            .Cells(i, 4) = d(.Cells(i, 1).Value & .Cells(i, 2).Value)
            If .Cells(i, 4) = "" Then .Cells(i, 4) = 0
        Next
    End With
End Sub

lwx228

zax010 发表于 2015-8-1 18:13
>>>>>>>>>>>>>>>>>>>>>>>>>>>

不比不知道，
原来直接用工作表函数=offset(,match(,,)-1,match(,,)-1,,)
分段计算更快得多。
Sub 整理()
    ActiveWindow.ActivateNext
nn = ActiveWorkbook.Name
gg = Sheets.Count
    ActiveWindow.ActivateNext
tt = Timer
    Sheets(i).Select
    cc = Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 1 To 32
    [a1] = "[" & nn & "]" & Workbooks(nn).Sheets(j).Name & "!"
    Cells(1, cc + j) = Workbooks(nn).Sheets(j).Name
   
   
    For k = 1 To 8
    g0 = Application.RoundDown([a2] / 8, 0)
    g = (k - 1) * g0 + 10
    [a6] = [a1].Offset(g, 0)
    [a7] = [a1].Offset(g + g0 - 1, 0)
   [a8].FormulaR1C1 = "=SUBSTITUTE(ADDRESS(1,MIN(MATCH(r6c,INDIRECT(r1c1&""1:1""),0)),4),1,)"
   [a9].FormulaR1C1 = "=SUBSTITUTE(ADDRESS(1,MIN(MATCH(r7c,INDIRECT(r1c1&""1:1""),0)),4),1,)"
   Range("a8:a9").Copy: Selection.PasteSpecial 3
       Cells(10, cc + j).Select
    ActiveCell.FormulaR1C1 = _
        "=OFFSET(INDIRECT(R1C1&""A1""),MATCH(RC2,INDIRECT(R1C1&""B:B""),)-1,MATCH(RC1,INDIRECT(R1C1&""1:1""),)-1,,)"
    Selection.Copy: Range(Cells(g, cc + j), Cells(g + g0 - 1, cc + j)).PasteSpecial 2: Selection.Copy: Selection.PasteSpecial 3
    Selection.Replace What:="#*", Replacement:="0"
    Next

  [a3] = Timer - tt
    Next
End Sub

山菊花

VBA：

1. Sub 整理()
   
2.     Dim nRow%, Arr(), Brr(), Crr() As Integer
   
3.     Dim ds As Object
   
4.     Set ds = CreateObject("Scripting.Dictionary")
   
5.     Arr = Workbooks("原数据").Sheets("Sheet1").Range("a1:ag30").Value
   
6.     For i = 3 To 30
   
7.         ds(Arr(i, 1)) = i
   
8.     Next
   
9.     For i = 2 To 33
   
10.         ds(Arr(1, i)) = i
    
11.     Next
    
12.     With Me
    
13.         nRow = .Range("b1048576").End(xlUp).Row
    
14.         Brr = .Range("a1:b" & nRow).Value
    
15.         ReDim Crr(6 To nRow, 1 To 1)
    
16.         
    
17.         For i = 6 To nRow
    
18.             Crr(i, 1) = Arr(ds(Brr(i, 2)), ds(Brr(i, 1)))
    
19.         Next
    
20.         .Range("c6:c" & nRow).Value = Crr
    
21.     End With
    
22. End Sub

复制代码

函数：

1. C6=VLOOKUP(B6,[原数据.xlsm]Sheet1!$A:$AG,MATCH(A6,[原数据.xlsm]Sheet1!$1:$1,),)

复制代码

原数据A列有重复数据。