[已解决]类似VLOOKUP的功能

X.Z.

希望达到类似VLOOKUP功能
可以由ALL这张表的 A栏第三码或是前面三码
搜寻LIST这张表D栏.. 对应的B栏名称至M栏
谢谢

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-12 14:13

1. Sub 提取Name()
   
2.     Dim arr, i&
   
3.     Dim dic As Object
   
4.    
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With Worksheets("List")
   
7.         arr = .Range("a1").CurrentRegion
   
8.         For i = LBound(arr) + 1 To UBound(arr)
   
9.             If Len(arr(i, 4)) > 0 Then dic(Split(arr(i, 4), ".")(2)) = arr(i, 2)
   
10.         Next
    
11.     End With
    
12.    
    
13.     With Worksheets("ALL")
    
14.         Dim arrb()
    
15.         arr = .Range("a1").CurrentRegion
    
16.         i = UBound(arr)
    
17.         ReDim arrb(1 To i, 1 To 1)
    
18.         For i = LBound(arr) + 1 To UBound(arr)
    
19.             If Len(arr(i, 1)) > 0 Then arrb(i, 1) = dic(Split(arr(i, 1), ".")(2))
    
20.         Next
    
21.         Range("m:m").ClearContents
    
22.         Range("m1").Resize(UBound(arrb), 1) = arrb
    
23. 
    
24.     End With
    
25.         
    
26. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 提取Name()
   
2.     Dim arr, i&
   
3.     Dim dic As Object
   
4.    
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With Worksheets("List")
   
7.         arr = .Range("a1").CurrentRegion
   
8.         For i = LBound(arr) + 1 To UBound(arr)
   
9.             If Len(arr(i, 4)) > 0 Then dic(Split(arr(i, 4), ".")(2)) = arr(i, 2)
   
10.         Next
    
11.     End With
    
12.    
    
13.     With Worksheets("ALL")
    
14.         Dim arrb()
    
15.         arr = .Range("a1").CurrentRegion
    
16.         i = UBound(arr)
    
17.         ReDim arrb(1 To i, 1 To 1)
    
18.         For i = LBound(arr) + 1 To UBound(arr)
    
19.             If Len(arr(i, 1)) > 0 Then arrb(i, 1) = dic(Split(arr(i, 1), ".")(2))
    
20.         Next
    
21.         Range("m:m").ClearContents
    
22.         Range("m1").Resize(UBound(arrb), 1) = arrb
    
23. 
    
24.     End With
    
25.         
    
26. End Sub
    

复制代码

X.Z.

hwc2ycy 发表于 2012-12-12 14:13

帥啊!
比想像中的 還要長!!!
需求有達到
感謝您 迅速回答
我來研究看看 代碼!!

hwc2ycy

代码其实不需要嫌长，只要写好了就成，这个不像写公式，不需要去追求那么短。

X.Z.

hwc2ycy 发表于 2012-12-12 14:19
代码其实不需要嫌长，只要写好了就成，这个不像写公式，不需要去追求那么短。

了解!! 感謝指導!!

X.Z.

對不起!如果可以的話抽空.幫我修改一下 把資料直接寫入到指定SHEET內,
而不是到 目前ACTICE的SHEET 謝謝您!!!

找到原因了
少了個.

   
    With Worksheets("All_Data")
        Dim arrb()
        arr = .Range("a1").CurrentRegion
        i3 = UBound(arr)
        ReDim arrb(1 To i3, 1 To 1)
        For i3 = LBound(arr) + 1 To UBound(arr)
            If Len(arr(i3, 1)) > 0 Then arrb(i3, 1) = dic(Split(arr(i3, 1), ".")(2))
        Next
        '.Range("m:m").ClearContents
        .Range("m1").Resize(UBound(arrb), 1) = arrb

     End With
'End Sub