Sub test0731()
Dim Arr, S$, T$, R%, Ro%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Range([A2], [C3].End(4))
With Sheets.Add
.[A1].Resize(UBound(Arr), 3) = Arr
With .[A1].CurrentRegion
.Sort key1:=.Item(1), order1:=xlAscending, _
key2:=.Item(3), order1:=xlAscending
End With
Arr = .[A1].CurrentRegion: .Delete
End With
[F1].CurrentRegion.Offset(1).ClearContents
ReDim Brr(1 To 1000, 1 To 7)
For R = 1 To UBound(Arr)
If InStr(S, "-" & Arr(R, 1) & "-") = 0 Then
Ro = Ro + 1: T = Arr(R, 1): K = 1
Brr(Ro, 1) = Arr(R, 1)
Brr(Ro, 2) = Arr(R, 2)
Brr(Ro, 5) = Arr(R, 3)
S = S & "," & "-" & Arr(R, 1) & "-"
Else
If Arr(R, 1) = T And K < 3 Then
Brr(Ro, 2 + K) = Arr(R, 2)
Brr(Ro, 5 + K) = Arr(R, 3)
K = K + 1
End If
End If
Next R
[F2].Resize(UBound(Brr), 7) = Brr
End Sub作者: ABK 時間: 2020-7-31 09:56
Sub TEST()
Dim Arr, Brr, i&, T$, R&, C&, Mx&
[F2:L2000].ClearContents
With Range([A1], [C65536].End(xlUp))
Brr = .Value '原資料存入brr
.Sort Key1:=.Item(1), Order1:=xlAscending, _
Key2:=.Item(3), Order2:=xlAscending, Header:=xlYes '排序
Arr = .Value '排序後資料存入arr
.Value = Brr 'brr貼回原區
End With
ReDim Brr(1 To UBound(Arr), 1 To 7)
For i = 2 To UBound(Arr)
If Arr(i, 1) <> T Then 'A欄--與上一格不相同時
R = R + 1: C = 0: T = Arr(i, 1): Brr(R, 1) = T '行號r+1: 欄位c歸零: T重新賦值: Brr填入T
End If
C = C + 1: If C > 3 Then GoTo 101 '累計c欄位: 大于3時--略過
Brr(R, C + 1) = Arr(i, 2): Brr(R, C + 4) = Arr(i, 3) '填入[料件]:填入[料件批次]
101: Next i
[F2:L2].Resize(R) = Brr
End Sub
