- 帖子
- 2798
- 主題
- 10
- 精華
- 0
- 積分
- 2854
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-4-20
|
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
========================== |
|
發表於 2020-8-1 10:16
| 