ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ¤£¹ïºÙ¤é´Á°µ¤ñ¹ï«á­n¦p¦ó§R°£¤£¬Û¦Pªº³¡¤À¨Ï¤§¹ï»ô¸ê®Æ

[µo°Ý] ¤£¹ïºÙ¤é´Á°µ¤ñ¹ï«á­n¦p¦ó§R°£¤£¬Û¦Pªº³¡¤À¨Ï¤§¹ï»ô¸ê®Æ

aaa.rar (7.4 KB)
½Ð°Ý¨C¤é­n¤Wºô»`¶°¥|²Õ¹ï·Ó¸ê®Æ¡A¦ý¤£¤@©w·|¦P¤é³£¦³¼Æ¾Ú¡A¬G¨C¨â²Õ¸ê®Æ¸Ìªº¤é´Á²Õ(¨Ò¦pdata1-1»Pdata1-2)¡A·|¥X²{¤é´Á¸ê®Æ¤£¯à¬Û¹ïÀ³ªº±¡ªp¡A­n¦p¦ó¼g¤@­Ó¯à¨â¬Û¤ñ¹ï«á§R°£¤£¹ïÀ³¤é´Áªºµ{¦¡

aaa.rar (10.56 KB)

¦^´_ 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)

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

ÁÂÁÂregister313¡B Hsieh ¨â¦ìª©¥DªºÀ°¦£¡A§Ú¥»¨ÓÁÙ¦b°Ñ¦Ò¥Î
Do
Loop Until  [¤@ª½¨ì±ø¥ó¬°]  Â÷¶}°j°é
¤£¹Lª©¥D­Ì¨Ï¥Î°}¦Cªº»yªk³t«×§ó§Ö¡AÁÂÁÂ

TOP

½Ð°ÝHsiehª©¤j
±zªº³o²Õµ{¦¡§Ú®M¥Î«á¡A·í¸ê®Æ¶qÅܦh®É¡A¾ã­Óµ{¦¡·|·í±¼¡A¦Óregister313 ª©¥Dªº«h¤£·|¡A¦P¼Ë¬O¹B¥Î°}¦Cªº¤è¦¡¡A¬°¦ó·|¦p¦¹?
¥t¥~½Ð±Ð¦pªG¨â²Õªº½d³òÅܤj(¨Ò¦psheet2 ªº¸ê®Æ)¡A­n«ç»ò­×§ïÁÂÁ¡C
aaa1.rar (176.41 KB)

TOP

¥»©«³Ì«á¥Ñ register313 ©ó 2012-5-29 21:47 ½s¿è

¦^´_ 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)

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

ÁÂÁÂhsieh¡B register313¨â¦ìª©¥Dªº«ü¾É¡A§Ú¦A¨Ó´ú¸Õ¡C

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-4-11 10:29 ½s¿è

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,·q½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æ«e:


°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Dim Brr, Crr, A(2), Y, Z, N&, i&, j&, xR As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("sheet2"): Set xR = Sh.UsedRange.Offset(1, 0): Brr = xR
For i = 0 To UBound(A)
   A(i) = Intersect(xR, [A:H].Offset(0, i * 8))
   For j = 1 To UBound(A(i))
      Y(A(i)(j, 2)) = Y(A(i)(j, 2)) + 1: Y(A(i)(j, 2) & "|" & i) = j
   Next
Next
For Each Z In Y.keys
   If Y(Z) = UBound(A) + 1 And InStr(Z, "|") = 0 And Z <> "" Then
      N = N + 1
      For i = 0 To UBound(A)
         For j = 1 To 8
            Brr(N, j + 8 * i) = Brr(Y(Z & "|" & i), j + 8 * i)
         Next
      Next
   End If
Next
xR.ClearContents
[A2].Resize(N, 8 * (UBound(A) + 1)) = Brr
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase A, Brr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : ¤£©È¨Æ¦h¡A¥u©È¦h¨Æ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD