- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
本帖最後由 n7822123 於 2020-7-31 02:50 編輯
回復 1# ABK
你的圖片[H3]欄位的值好像錯了~~~
時間晚了所以沒寫註解，有問題再發問
程式如下，試試看!
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 |
|
發表於 2020-7-31 02:45
| 
