­ã´£³¡ªL

¦^´_ 30# PJChen

Sub ³Ì«á®Ä´Á()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'Set BK = Workbooks("³Ì·s®w¦s.xlsx")
'BK.Sheets("³Ì«á®Ä´Á").Activate
R = [­¸¤ñ!HE65536].End(xlUp).Row
Arr = Sheets("­¸¤ñ").Range("F1:F" & R)
Brr = Sheets("­¸¤ñ").Range("HD1:HE" & R)
ReDim Crr(1 To R, 1 To 2)
For i = 4 To R
For j = 1 To 2
    If Val(Brr(i, j)) > 0 Then
       N(j) = N(j) + 1: Crr(N(j), j) = Arr(i, 1)
       If N(j) > NN Then NN = N(j)
    End If
Next j
Next i
If NN = 0 Then Exit Sub
With Sheets("³Ì«á®Ä´Á")
    .[J4:K4].Resize(NN) = Crr
    If NN <= 1 Then Exit Sub
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
End With
End Sub

Andy2483

¦^´_ 31# ­ã´£³¡ªL
'ÁÂÁ«e½ú
'«á¾Ç¦b¦¹©«¾Ç²ß¨ì
'1.¨S¦³²`¤J¾Ç²ß±o¤£¨ìºëµØ
'2.²ß±o§å¦¸«Å§iÅܼƥB§å¦¸¼Æ»P°j°é·f°t¨Ï¥Î!ªì¶}©l¥u¥H¬°¤Ö«Å§i´X­ÓÅܼÆ
'3.²ß±o If N(j) > NN Then ¨ú³Ì¤j¼Æªº¤èªk
'4.²ß±o [J4:K4].Resize(NN) = Crr,¥H«e¥u·| [J4].Resize(NN,2)
'5.©P¨ìªº¨¾¿ù»Ý­n¦A²Ö¿n¸gÅç!¤~¯à¿ì¨ì
¥H¤U¤ß±oµù¸Ñ½Ð¦b«ü±Ð! ÁÂÁ«e½ú

Sub ³Ì«á®Ä´Á()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'¡ô«Å§iÅܼÆ
R = [­¸¤ñ!HE65536].End(xlUp).Row
'¡ô¥OR¬O HEÄæÀx¦s®æ¦³¤º®eªº³Ì«á¤@¦C¼Æ
Arr = Sheets("­¸¤ñ").Range("F1:F" & R)
'¡ô¥OArr¬O°}¦C ­Ë¤J­¸¤ñªí ªºF1¨ì
'FÄ檺(HEÄæÀx¦s®æ¦³¤º®eªº³Ì«á¤@¦C¼Æ) ªº­È
Brr = Sheets("­¸¤ñ").Range("HD1:HE" & R)
'¡ô¥OBrr¬O°}¦C ­Ë¤J­¸¤ñªí ªºHD1¨ì
'HEÄ檺(HEÄæÀx¦s®æ¦³¤º®eªº³Ì«á¤@¦C¼Æ) ªº­È
ReDim Crr(1 To R, 1 To 2)
'¡ô«Å§iCrr°}¦Cªº¤j¤p ºî¤è¦V 1¨ì HEÄæÀx¦s®æ¦³¤º®eªº³Ì«á¤@¦C¼Æ
'¾î¤è¦V 1 ¨ì 2
For i = 4 To R
'¡ô³]¥~¶¶°j°é ±q4 ¨ì R
   For j = 1 To 2
   '¡ô³]¤º¶¶°j°é ±q 1 ¨ì 2
      If Val(Brr(i, j)) > 0 Then
      '¡ô¦pªG ´f ²Î ³o¨âÄæ¸Ìªº­È¤j©ó0
         N(j) = N(j) + 1
         '¡ôN¬O³o¨âÄæ²Å¦XIf±ø¥ó¦¸¼ÆªºÅܼÆ!ªì©l­È¬O0
         Crr(N(j), j) = Arr(i, 1)
         '¡ôCrr°}¦C±q²Ä¤@¦C¶}©l©ñ¤J²Å¦X±ø¥ó ªº½¦±aÃC¦â
         If N(j) > NN Then
         '¡ô¦pªG¤j©ó NN
         '¡ô·íN(j)=1®É,NNªºªì©l­È¬O0 !±ø¥ó¦¨¥ß
            NN = N(j)
            '¡ô±ø¥ó¦¨¥ß!´NÅýNN =²Å¦XIf±ø¥ó¦¸¼Æ
            '¡ô·íN(j)=1®É ±ø¥ó¦¨¥ß! NN=1
            '¡ô«áÄò¦pªG N(1) N(2)¤£¬Ûµ¥!NN·|¸Ë¤J³Ì¤j¼Æ
         End If
      End If
   Next j
Next i
If NN = 0 Then
'¡ô¦pªGN()ªº³Ì¤j¼ÆNN ¬O0!§¹¥þ¨S¦³²Å¦X±ø¥óªº¸ê®Æ
   Exit Sub
   '¡ôµ²§ôµ{§Ç
End If
With Sheets("³Ì«á®Ä´Á")
'¡ô±µ¤U¨ÓÃö©ó ³Ì«á®Ä´Áªíªº¬ÛÃöµ{§Ç(«e­±¦³ ªÅ¥Õ+"."²Å¸¹ªº")
    .[J4:K4].Resize(NN) = Crr
    '¡ô¥Ñ ³Ì«á®Ä´Áªí ªº[J4:K4](§t)¶}©l¦V¤UÂX®i NN¦Cªº½d³ò¶K¤JCrrªº­È
    'ÁöµM ReDim Crr(1 To R, 1 To 2)«Å§iªº½d³ò¤ñ ³Ì«áµ²ªG½d³ò¤j!
    '¦ý¬Oºë·Ç­pºâ!¦³®ÄResizeÂX®iµ²ªG½d³ò,´N¤£·|¼vÅT¨ä¥LÀx¦s®æ
    If NN <= 1 Then Exit Sub
    '¡ô¦pªGN()ªº³Ì¤j¼ÆNN=1,´N µ²§ôµ{§Ç
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    '¡ô±N ³Ì«á®Ä´Áªí[L4:AB4]Àx¦s®æ ½Æ»s¨ì
    '³Ì«á®Ä´Áªí[L5:AB5](§t)¶}©l¦V¤UÂX®i NN-1¦C
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
    '¡ô±N ³Ì«á®Ä´Áªí[A4:H4]Àx¦s®æ ½Æ»s¨ì
    '³Ì«á®Ä´Áªí[A5:H5](§t)¶}©l¦V¤UÂX®i NN-1¦C
End With
End Sub

Andy2483

¦^´_ 31# ­ã´£³¡ªL
ÁÂÁ«e½ú
«á¾Ç¥Î¨â­Ó°}¦C+¨â­Ó¦r¨å³B²z,½Ð«e½ú¦A«ü¾É!

Option Explicit
Sub TEST_20221028()
Dim Arr, Brr, i&, j&, X, Y, C, R
R = [­¸¤ñ!HE65536].End(xlUp).Row
Arr = Sheets("­¸¤ñ").Range("F1:F" & R)
Brr = Sheets("­¸¤ñ").Range("HD1:HE" & R)
Set X = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
For i = 4 To R
   If Val(Brr(i, 1)) > 0 Then
      X(Brr(i, 1) & "|" & i) = Arr(i, 1)
   End If
   If Val(Brr(i, 2)) > 0 Then
      Y(Brr(i, 2) & "|" & i) = Arr(i, 1)
   End If
Next
With Sheets("³Ì«á®Ä´Á")
   .[J4:K4].Resize(R).ClearContents
   .[L5:AB5].Resize(R).ClearContents
   .[A5:H5].Resize(R).ClearContents
   If X.Count > 0 Then
      .[J4].Resize(X.Count, 1) = Application.Transpose(X.items)
   End If
   If Y.Count > 0 Then
      .[K4].Resize(Y.Count, 1) = Application.Transpose(Y.items)
   End If
   C = IIf(X.Count >= Y.Count, X.Count, Y.Count)
   If C <= 1 Then Exit Sub
   .[L4:AB4].Copy .[L5:AB5].Resize(C - 1)
   .[A4:H4].Copy .[A5:H5].Resize(C - 1)
End With
End Sub
Sub ²M°£()
With Sheets("³Ì«á®Ä´Á")
   .[J4:K4].Resize(100).ClearContents
   .[L5:AB5].Resize(100).ClearContents
   .[A5:H5].Resize(100).ClearContents
End With
End Sub