|
- Sub lqxs()
- Dim Arr1, i&, Arr2, j&, r3%, Arr3(), r4%, Arr4()
- Dim d, d1, t, x$
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- Sheet1.Activate
- Arr1 = [a1].CurrentRegion
- Arr2 = [j1].CurrentRegion
- For i = 2 To UBound(Arr1)
- x = ""
- For j = 1 To UBound(Arr1, 2)
- x = x & Arr1(i, j) & ","
- Next
- d(x) = ""
- Next
- For i = 2 To UBound(Arr2)
- x = ""
- For j = 1 To UBound(Arr2, 2)
- x = x & Arr2(i, j) & ","
- Next
- d1(x) = ""
- If d.exists(x) Then
- r4 = r4 + 1
- ReDim Preserve Arr4(1 To r4)
- Arr4(r4) = x
- End If
- Next
- For i = 2 To UBound(Arr1)
- x = ""
- For j = 1 To UBound(Arr1, 2)
- x = x & Arr1(i, j) & ","
- Next
- If Not d1.exists(x) Then
- r3 = r3 + 1
- ReDim Preserve Arr3(1 To r3)
- Arr3(r3) = x
- End If
- Next
- Application.DisplayAlerts = False
- [s2].Resize(UBound(Arr3), 1) = Application.Transpose(Arr3)
- [ab2].Resize(UBound(Arr4), 1) = Application.Transpose(Arr4)
- [s2].Resize(UBound(Arr3)).TextToColumns Comma:=True
- [ab2].Resize(UBound(Arr4)).TextToColumns Comma:=True
- Application.DisplayAlerts = True
- End Sub
复制代码 |
|