VBA字典查找

linda80200

VBA字典查找.zip (12.71 KB, 下载次数: 116)

2016-9-24 22:19 上传

点击文件名下载附件

详见附件，求指教了，谢谢大家。

huang1314wei

太简单的不想写，A2输入公式  =VLOOKUP(RC[1],Sheet1!C:C[1],2,FALSE)  下拉   按F9刷新

microyip

1. Sub 字典查找()
   
2.     Dim oDic As Object
   
3.     Dim vData As Variant
   
4.     Dim iData As Integer
   
5.     Dim vFill As Variant
   
6.    
   
7.     Set oDic = CreateObject("Scripting.Dictionary")
   
8.     vData = Sheet1.UsedRange.Value
   
9.     For iData = 2 To UBound(vData)
   
10.         If Trim(vData(iData, 1)) <> "" And Not oDic.Exists(Trim(vData(iData, 1))) Then oDic(Trim(vData(iData, 1))) = vData(iData, 2)
    
11.     Next
    
12.     With Sheets("Sheet2")
    
13.         iData = .[B65536].End(xlUp).Row
    
14.         ReDim vFill(1 To iData - 1, 1 To 1)
    
15.         vData = .Range("B2:B" & iData).Value
    
16.         For iData = 1 To UBound(vData)
    
17.             If oDic.Exists(Trim(vData(iData, 1))) Then vFill(iData, 1) = oDic(Trim(vData(iData, 1)))
    
18.         Next
    
19.         .Range("A2:A" & iData) = vFill
    
20.     End With
    
21. End Sub
    

复制代码

microyip

附上附件以供参考

hhjjpp

为何旧事重提、重新发帖？原来有何不妥？

1. rivate Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, n&, d
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. arr = Sheet1.[f2].CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.     d(arr(i, 1)) = arr(i, 2)
   
8. Next
   
9. Set arr = Nothing                 '释放数组占用内存,提高速度
   
10. n = [a65536].End(xlUp).Row - 1
    
11. brr = [a2].Resize(n)
    
12. For i = 1 To n
    
13.     brr(i, 1) = d(brr(i, 1))      '就地使用原数组,减少内存占用
    
14. Next
    
15. [b2].Resize(n) = brr
    
16. Application.ScreenUpdating = True
    
17. End Sub
    

复制代码

hhjjpp

稍改一下就是了

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, n&, d
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. arr = Sheet1.[a2].CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.     d(arr(i, 1)) = arr(i, 2)
   
8. Next
   
9. Set arr = Nothing                 '释放数组占用内存,提高速度
   
10. n = [b65536].End(xlUp).Row - 1
    
11. brr = [b2].Resize(n)
    
12. For i = 1 To n
    
13.     brr(i, 1) = d(brr(i, 1))      '就地使用原数组,减少内存占用
    
14. Next
    
15. [a2].Resize(n) = brr
    
16. Application.ScreenUpdating = True
    
17. End Sub
    

复制代码

linda80200

hhjjpp 发表于 2016-9-25 09:27
稍改一下就是了

您好，谢谢您的回复。之前自己没注意，操作失误导致有问题，带来困扰抱歉了。下次会注意此问题

sunxh

字典学习中

williams12388

请参考：
Sub 宏1()
'
' 宏1 宏
'
Dim ds
Dim arr, i, n As Integer


Set ds = CreateObject("scripting.dictionary")
Sheets("sheet1").Select
arr = Sheet1.[a2].CurrentRegion
For i = 2 To UBound(arr)
ds(arr(i, 1)) = arr(i, 2)
Next
Set arr = Nothing

Sheets("sheet2").Select

For n = 2 To Range("B6553").End(xlUp).Row

s = Range("B" & n).Value
If ds.exists(s) Then
Range("A" & n) = ds(s)
End If

Next


'
End Sub