­ã´£³¡ª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