register313

¦^´_ 1# yuch8663

1. Sub xx()
   
2. Dim Ar1(), Ar2()
   
3. Sheets("sheet2").Cells = ""
   
4. Sheets("sheet1").Rows(1).Copy Sheets("sheet2").Rows(1)
   
5. For C = 1 To 15 Step 4
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Set d2 = CreateObject("scripting.dictionary")
   
8.   Sheets("sheet1").Select
   
9.   x = Cells(2, C).End(xlDown).Row
   
10.   y = Cells(2, C + 2).End(xlDown).Row
    
11.   Ar1 = Range(Cells(2, C), Cells(x, C + 1))
    
12.   Ar2 = Range(Cells(2, C + 2), Cells(y, C + 3))
    
13.   For I = 1 To UBound(Ar1)
    
14.     d1(Ar1(I, 1)) = Ar1(I, 2)
    
15.   Next I
    
16.   For I = 1 To UBound(Ar2)
    
17.     d2(Ar2(I, 1)) = Ar2(I, 2)
    
18.   Next I
    
19.   For J = 1 To UBound(Ar1)
    
20.     If Not d2.Exists(Ar1(J, 1)) Then d1.Remove (Ar1(J, 1))
    
21.   Next J
    
22.   For J = 1 To UBound(Ar2)
    
23.     If Not d1.Exists(Ar2(J, 1)) Then d2.Remove (Ar2(J, 1))
    
24.   Next J
    
25.   Sheets("sheet2").Cells(2, C).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
26.   Sheets("sheet2").Cells(2, C + 1).Resize(d1.Count, 1) = Application.Transpose(d1.items)
    
27.   Sheets("sheet2").Cells(2, C + 2).Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
28.   Sheets("sheet2").Cells(2, C + 3).Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
29.   Erase Ar1: Erase Ar2
    
30.   Set d1 = Nothing: Set d2 = Nothing
    
31. Next C
    
32. End Sub

½Æ»s¥N½X

aaa1.rar (13.17 KB)

¤U¸ü¦¸¼Æ: 9

2012-5-28 15:08

register313

¦^´_ 5# yuch8663

¥Î­ì¤èªk­×§ï,¦ýª½±µ¨ú¥NSHEET2

1. Sub yy()
   
2. Dim Ar1(), Ar2()
   
3.   Set d1 = CreateObject("scripting.dictionary")
   
4.   Set d2 = CreateObject("scripting.dictionary")
   
5.   Sheets("sheet2").Select
   
6.   x = Cells(2, "A").End(xlDown).Row
   
7.   y = Cells(2, "I").End(xlDown).Row
   
8.   Ar1 = Range(Cells(2, "A"), Cells(x, "H"))
   
9.   Ar2 = Range(Cells(2, "I"), Cells(y, "P"))
   
10.   For I = 1 To UBound(Ar1)
    
11.     d1(Ar1(I, 2)) = Application.Index(Ar1, I, 0)
    
12.   Next I
    
13.   For I = 1 To UBound(Ar2)
    
14.     d2(Ar2(I, 2)) = Application.Index(Ar2, I, 0)
    
15.   Next I
    
16.   For J = 1 To UBound(Ar1)
    
17.     If Not d2.Exists(Ar1(J, 2)) Then d1.Remove (Ar1(J, 2))
    
18.   Next J
    
19.   For J = 1 To UBound(Ar2)
    
20.     If Not d1.Exists(Ar2(J, 2)) Then d2.Remove (Ar2(J, 2))
    
21.   Next J
    
22.   [A1].CurrentRegion.Offset(1, 0) = ""
    
23.   [A2].Resize(d1.Count, 8) = Application.Transpose(Application.Transpose(d1.items))
    
24.   [I2].Resize(d2.Count, 8) = Application.Transpose(Application.Transpose(d2.items))
    
25. End Sub

½Æ»s¥N½X

aaa1.rar (178.04 KB)

¤U¸ü¦¸¼Æ: 6

2012-5-29 21:47