[已解决]字典查找相同并填充颜色

shixyi37

Sub test注释1()
    Dim arr, temp, brr
    Dim d
    Dim i&, k&
    Set d = CreateObject("scripting.dictionary")    '建立字典
    arr = Sheets(1).Range("A1:E" & Sheets(1).Cells(Rows.Count, 1).End(3).Row)  '将A1所在区域写入数组
        For i = 1 To UBound(arr)   '在数组中循环
            d(arr(i, 1) & "") = arr(i, 2) & "\" & arr(i, 3) & "\" & arr(i, 4) & "\" & arr(i, 5) '将数组中的arr(i,1)&""写入字典，并赋于arr(i,2)的值
        Next
    temp = Sheets(1).Range("H1:L" & Sheets(1).Cells(Rows.Count, 8).End(3).Row)  '将d1所在区域写入数组temp
    ReDim brr(1 To UBound(temp), 1 To 1)    '重新定义数组brr的大小
        For k = 1 To UBound(temp)   '在数组中在循环
            brr(k, 1) = d(temp(k, 1))   '将字典中d(temp(k, 1))所对应的值赋给brr(k,1)，与arr(i,2)即第二列相对应
        Next
    Sheets(1).Range("I1").Resize(UBound(brr), 1) = brr   '将数组brr输出到单元格

    Set d = Nothing
    Sheets(1).Columns("I:I").TextToColumns Destination:=Sheets(1).Range("I1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Other:=True, OtherChar:="\"  '分列
End Sub


这是查找H列数据是否存在于A列中并显示对应行数据的宏，我需要对存在于A列的单元格填充颜色，怎么修改？另外，字典的赋值怎么实现多列赋值？我不会只能采取”d(arr(i, 1) & "") = arr(i, 2) & "\" & arr(i, 3) & "\" & arr(i, 4) & "\" & arr(i, 5) “这个办法，然后进行分列。需求见图：

VBA用字典来替代函数的Vlookup.zip (24.16 KB, 下载次数: 23)

2016-12-28 16:45 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2016-12-28 19:22

1. Sub Macro1()
   
2. Dim arr, brr, crr, d,i&,j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. brr = Range("h1:h" & Range("h65536").End(xlUp).Row)
   
6. ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2) - 1)
   
7. [a:a].Interior.ColorIndex = xlNone
   
8. [i:l].ClearContents
   
9. For i = 1 To UBound(arr)
   
10.     d(arr(i, 1)) = i
    
11. Next
    
12. For i = 1 To UBound(brr)
    
13.     If d.exists(brr(i, 1)) Then
    
14.         n = d(brr(i, 1))
    
15.         Cells(n, 1).Interior.ColorIndex = 3
    
16.         For j = 2 To UBound(arr, 2)
    
17.             crr(i, j - 1) = arr(n, j)
    
18.         Next
    
19.     End If
    
20. Next
    
21. Range("i1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
22. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d,i&,j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. brr = Range("h1:h" & Range("h65536").End(xlUp).Row)
   
6. ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2) - 1)
   
7. [a:a].Interior.ColorIndex = xlNone
   
8. [i:l].ClearContents
   
9. For i = 1 To UBound(arr)
   
10.     d(arr(i, 1)) = i
    
11. Next
    
12. For i = 1 To UBound(brr)
    
13.     If d.exists(brr(i, 1)) Then
    
14.         n = d(brr(i, 1))
    
15.         Cells(n, 1).Interior.ColorIndex = 3
    
16.         For j = 2 To UBound(arr, 2)
    
17.             crr(i, j - 1) = arr(n, j)
    
18.         Next
    
19.     End If
    
20. Next
    
21. Range("i1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
22. End Sub

复制代码