数据匹配的问题.求老师帮忙！谢谢！

Bobli0208

liulang0808 发表于 2014-8-4 20:11
使用字典吧。。。
这个可以有的

能帮忙搞搞嘛？我刚接触没多久。正在学习当中。

liulang0808

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    arr = ActiveSheet.UsedRange
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            d1(arr(j, 1)) = ""
        End If
        
        If Len(arr(j, 2)) > 0 Then
            d2(arr(j, 2)) = ""
        End If
        
    Next j
    If d1.Count > 0 Then
       Cells(2, 4).Resize(d1.Count) = WorksheetFunction.Transpose(d1.keys)
    End If
    arr1 = d2.keys
    a = d1.Count + 2
    For j = 0 To UBound(arr1)
        If d1.exists(arr1(j)) Then
            Columns(4).Find(arr1(j), lookat:=xlWhole).Offset(0, 1) = arr1(j)
        Else
            Cells(a, "e") = arr1(j)
            a = a + 1
        End If
    Next j
    Application.ScreenUpdating = True
End Sub

liulang0808

具体见附件内容

maditate

1. Sub test()
   
2.     arr = UsedRange
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set dd = CreateObject("Scripting.Dictionary")
   
5.     For h = LBound(arr) To UBound(arr)
   
6.          d(arr(h, 1)) = ""
   
7.     Next h
   
8.     For h = LBound(arr) To UBound(arr)
   
9.        If d.exists(arr(h, 2)) Then
   
10.           d(arr(h, 2)) = arr(h, 2)
    
11.         Else
    
12.          dd(arr(h, 2)) = ""
    
13.        End If
    
14.     Next h
    
15.     Range("C:E").ClearContents
    
16.     Range("D1").Resize(d.Count) = Application.Transpose(d.keys)
    
17.     Range("E1").Resize(d.Count) = Application.Transpose(d.items)
    
18.     Range("D1").Offset(rowOffset:=d.Count - 1).Resize(dd.Count) = Application.Transpose(dd.items)
    
19.     Range("E1").Offset(rowOffset:=d.Count - 1).Resize(dd.Count) = Application.Transpose(dd.keys)
    
20. End Sub

复制代码

Bobli0208

liulang0808 发表于 2014-8-4 21:11
具体见附件内容

3q.谢谢 可以了。

w343516704

‘可以用加了on error resume next的放错语句用字典提取出来
’比方说

1. Sub zidian()
   
2. Dim a
   
3. Dim dict
   
4. On Error Resume Next
   
5. Set dict = CreateObject("scripting.dictionary")
   
6. For a = 1 To 9
   
7. dict.Add Range("a" & a).Value, Nothing
   
8. Next
   
9. End Sub

复制代码

Bobli0208

maditate 发表于 2014-8-4 21:16

谢谢了！ 可以了。！