[已解决]求一段类似vlookup的代码,条件有点多,求大神相助

eking_tang

因为其他原因,不能用公式,只能求VBA代码,麻烦各位了,感谢先.

最佳答案

月排行榜 / 总排行榜

冥王

2015-6-12 13:04

1. Sub ddd()
   
2.     Dim dic As Object, d As Object, arr, sht As Worksheet
   
3.     Dim iRow%, i%, j%, n%, brr()
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     With ThisWorkbook
   
7.         arr = .Sheets("RATE").Range("A1").CurrentRegion
   
8.         For i = LBound(arr, 2) + 2 To UBound(arr, 2)
   
9.             dic(arr(1, i)) = i           '存储列信息
   
10.         Next
    
11.         For j = LBound(arr) + 1 To UBound(arr)
    
12.             d(CInt(arr(j, 1))) = j             '存储行信息
    
13.         Next
    
14.         For Each sht In .Sheets          '循环工作表
    
15.             If sht.name <> "RATE" Then
    
16.                 iRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).row
    
17.                 ReDim brr(1 To iRow - 6)
    
18.                 For n = 7 To iRow
    
19.                     brr(n - 6) = arr(d(CInt(sht.Cells(n, "B"))), dic(sht.name))
    
20.                 Next
    
21.                 sht.Cells(8, "A").Resize(iRow - 7, 1).ClearContents
    
22.                 sht.Cells(8, "A").Resize(iRow - 7, 1) = Application.Transpose(brr)
    
23.             End If
    
24.         Next
    
25.         Set dic = Nothing
    
26.         Set d = Nothing
    
27.     End With
    
28. End Sub

复制代码

跳转到最佳答案楼层

冥王

1. Sub ddd()
   
2.     Dim dic As Object, d As Object, arr, sht As Worksheet
   
3.     Dim iRow%, i%, j%, n%, brr()
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     With ThisWorkbook
   
7.         arr = .Sheets("RATE").Range("A1").CurrentRegion
   
8.         For i = LBound(arr, 2) + 2 To UBound(arr, 2)
   
9.             dic(arr(1, i)) = i           '存储列信息
   
10.         Next
    
11.         For j = LBound(arr) + 1 To UBound(arr)
    
12.             d(CInt(arr(j, 1))) = j             '存储行信息
    
13.         Next
    
14.         For Each sht In .Sheets          '循环工作表
    
15.             If sht.name <> "RATE" Then
    
16.                 iRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).row
    
17.                 ReDim brr(1 To iRow - 6)
    
18.                 For n = 7 To iRow
    
19.                     brr(n - 6) = arr(d(CInt(sht.Cells(n, "B"))), dic(sht.name))
    
20.                 Next
    
21.                 sht.Cells(8, "A").Resize(iRow - 7, 1).ClearContents
    
22.                 sht.Cells(8, "A").Resize(iRow - 7, 1) = Application.Transpose(brr)
    
23.             End If
    
24.         Next
    
25.         Set dic = Nothing
    
26.         Set d = Nothing
    
27.     End With
    
28. End Sub

复制代码

wp8680

1. Sub 按钮5_Click()
   
2.     Dim arr, k&, il&
   
3.     Dim dic, a&, st
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     If Sheets("RATE").UsedRange.Count > 1 Then arr = Sheets("RATE").UsedRange
   
6.     For k = 1 To UBound(arr, 2)
   
7.         If ActiveSheet.name = arr(1, k) Then il = k: Exit For
   
8.     Next k
   
9.     For k = 1 To UBound(arr, 1)
   
10.         dic(arr(k, 1)) = arr(k, il)
    
11.     Next k
    
12.     Set rg = ActiveSheet.Range("b7")
    
13.     Do While Len(rg.Offset(a, 0)) > 0
    
14.         st = rg.Offset(a, 0).Value
    
15.         If dic.exists(st) = True Then
    
16.             rg.Offset(a + 1, -1) = dic.Item(st)
    
17.         End If
    
18.         a = a + 1
    
19.     Loop
    
20. End Sub

复制代码