- 帖子
- 254
- 主題
- 6
- 精華
- 0
- 積分
- 310
- 點名
- 0
- 作業系統
- W10
- 軟體版本
- Excel 2016
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2019-6-16
- 最後登錄
- 2025-6-21
|
32#
發表於 2020-10-21 21:56
| 只看該作者
回復 30# wei9133
你把 jcchiang前輩的 以下這段改一下 看看 是不是你要的結果
Sub ex3()
Dim d As Object, ar As Object, r
Dim i%, AA$, a
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ar = Sheets(1).[a1].CurrentRegion
For i = 1 To ar.Rows.Count
AA = Join(Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 102))), ",") & "," & ar(i, 106) '建立判斷條件
If Not d.exists(AA) Then '字典內查無該條件
a = Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 115)))
If a(103) = "" Then a(103) = 1 '勝場空白填入1
d(AA) = a '將資料放回字典
Else
a = Application.Transpose(Application.Transpose(d(AA))) '將字典資料取出
If ar(i, 103) = "" Then a(103) = a(103) + 1 Else a(103) = a(103) + ar(i, 103) '勝場空白勝場累加1,不是空白則將欄位值相加
a(105) = a(105) + ar(i, 105) '敗局累加
For Each r In Array(104, 107, 109, 115) '將備註,DC,DE,DK欄位資料合併
If a(r) <> "" And ar(i, r) <> "" Then '如果字典與欄位都有資料,使用","相連
a(r) = a(r) & "," & ar(i, r)
ElseIf a(r) = "" And ar(i, r) <> "" Then '如果字典資料為空白,欄位是有資料的,使用欄位資料
a(r) = ar(i, r)
End If
Next
d(AA) = a '將資料放回字典
End If
Next
With Sheets(2) '在第二個Sheet填入資料
.[a1].CurrentRegion.Clear '清除Sheet資料
.[a1].Resize(d.Count, 115) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
'For Each r In .Range(.[cy2], .[cy2].End(4)) '保留勝場+1
' r.Value = r.Value + 1
'Next
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub |
|
