Hsieh

¦^´_ 1# yuch8663
¦b¦P¤@¤u§@ªíª½±µ§R°£¤£¹ïÀ³¸ê®Æ

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For k = 1 To [IV1].End(xlToLeft).Column Step 4 'Äæ¦ì
   
4. For I = 0 To 2 Step 2 '¤é´ÁÄæ¦ì
   
5.    For Each a In Range(Cells(1, k + I), Cells(1, k + I).End(xlDown)) '¨C­Ó¤é´Á
   
6.      If Application.CountIf(Cells(1, k).Resize(, 3).EntireColumn, a) > 1 Then
   
7.        If IsEmpty(d(a.Value)) Then '²Ä¤@¦¸¹J¨ì¤é´Á
   
8.           d(a.Value) = Array(a.Value, a.Offset(, 1).Value, a.Value, "")
   
9.           Else '²Ä¤G¦¸¤é´Á
   
10.           ar = d(a.Value)
    
11.           ar(3) = a.Offset(, 1).Value
    
12.           d(a.Value) = ar
    
13.           Erase ar
    
14.         End If
    
15.      End If
    
16.     Next
    
17. Next
    
18. Cells(1, k).Resize(, 4).EntireColumn = "" '²MªÅ
    
19. Cells(1, k).Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items)) '¼g¤J
    
20. d.RemoveAll '²¾°£¦r¨å¤º®e
    
21. Next
    
22. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 5# yuch8663

¸Õ¸Õ¦Û¤v¿é¤J¤é´ÁÄæ¦ì»PÄæ¼Æ¥H²Å¦X¥ô·Nªí®æ¤ñ¹ï

1. Sub nn()
   
2. Dim k%, s&, j&, n%, n1%, i%, Ay(), Ar()
   
3. Set d = CreateObject("Scripting.Dictionary") '©Ò¦³¤é´Á®e¾¹
   
4. Set d1 = CreateObject("Scripting.Dictionary") 'data1®e¾¹
   
5. Set d2 = CreateObject("Scripting.Dictionary") 'data2®e¾¹
   
6. n = InputBox("¿é¤J²Ä¤@­Ó¤é´ÁÄæ¦ì­È", , 2) '¿é¤J²Ä¤@­Ó¤é´ÁÄæ¦ì
   
7. n1 = InputBox("¿é¤J¤é´ÁÄæ¦ì®t", , 8) '¿é¤J2ªí®æ¤é´ÁÄæ¦ì¬Û®tÄæ¦ì¼Æ
   
8. ReDim A(n1) '¨C­ÓdataªºÄæ¦ì¼Æ¶q
   
9. ReDim C(n1 * 2) '2ªí®æÁ`Äæ¼Æ
   
10. Ar = Range("A1").CurrentRegion.Offset(1).Value 'A2¶}©l¥H¤U©Ò¦³¸ê®Æ¶°¦X
    
11. For k = n To UBound(Ar, 2) Step n1 * 2  '±q²Ä¤@­Ó¤é´ÁÄæ¦ì¶}©l¡A¥HÄæ¦ì®t¬°¯Å¶Z°µÄæ¦ì¦^°é
    
12.    For i = 0 To n1 Step n1  '¦bdata1»Pdata2ªº¤é´ÁÄæ¦ì
    
13.      For j = 1 To UBound(Ar, 1) '¥H¦C§@°j°é
    
14.       d(Ar(j, k + i)) = "" '¬ö¿ý¤é´Á
    
15.       For x = 0 To n1 - 1
    
16.          A(x) = Ar(j, k + i - (n - x - 1)) '¼g¤J¼È¦s°}¦C
    
17.       Next
    
18.       If i = 0 Then d1(Ar(j, k + i)) = A '±N°}¦C¶Çµ¹¦r¨å
    
19.       If i = n1 Then d2(Ar(j, k + i)) = A '±N°}¦C¶Çµ¹¦r¨å
    
20.      Next
    
21.    Next
    
22.    For Each ky In d.keys
    
23.       If d1.exists(ky) = True And d2.exists(ky) = True Then '¦pªG2­Ódata®e¾¹³£§ä¨ì¦¹¯Á¤Þ
    
24.       For i = 0 To n1 * 2 - 1
    
25.         If i < n1 Then C(i) = d1(ky)(i) Else C(i) = d2(ky)(i - n1) '¼g¤J¼È¦s°}¦C
    
26.       Next
    
27.       ReDim Preserve Ay(s) '±N¼È¦s°}¦C¶Çµ¹°ÊºA°}¦C
    
28.       Ay(s) = C
    
29.       s = s + 1
    
30.       End If
    
31.    Next
    
32.   Range(Cells(2, k - (n - 1)).Resize(, n1 * 2), Cells(Rows.Count, k - (n - 1)).Resize(, n1 * 2)) = "" '²M°£¸ê®Æ
    
33.   Cells(2, k - (n - 1)).Resize(s, n1 * 2) = Application.Transpose(Application.Transpose(Ay)) '¼g¤J¸ê®Æ
    
34.   s = 0: Erase Ay '²MªÅ°}¦C
    
35.   d.RemoveAll '²¾°£¦r¨å¤º®e
    
36.   d1.RemoveAll '²¾°£¦r¨å¤º®e
    
37.   d2.RemoveAll '²¾°£¦r¨å¤º®e
    
38. Next
    
39. End Sub

½Æ»s¥N½X