- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
本帖最後由 c_c_lai 於 2014-5-31 10:52 編輯
回復 1# ii31sakura
沒留意你仍是小學生等級，是無法下載的。
所以將程式碼貼上：- Sub Ex()
- Dim 第一種組合 As Object, 第二種組合 As Object, rng As Range
-
- Set 第一種組合 = CreateObject("Scripting.Dictionary")
- Set 第二種組合 = CreateObject("Scripting.Dictionary")
-
- With Sheets("DATA")
- ' .[F:L].ClearContents ' 保留複製標題
- .[F12:L65535].ClearContents
- For Each rng In .Range([A2], [A2].End(xlDown)) ' 每日
- If IsEmpty(第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then ' 寫入字典
- 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Value, rng.Offset(, 1).Value, rng.Offset(, 2).Value, Val(rng.Offset(, 3).Value))
- Else
- 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Value, rng.Offset(, 1).Value, rng.Offset(, 2).Value, 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value)(3) + Val(rng.Offset(, 3).Value))
- End If
-
- If IsEmpty(第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then ' 寫入字典
- 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Offset(, 1).Value, rng.Offset(, 2).Value, Val(rng.Offset(, 3).Value))
- Else
- 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Offset(, 1).Value, rng.Offset(, 2).Value, 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value)(2) + Val(rng.Offset(, 3).Value))
- End If
- Next
-
- .[F12].Resize(第一種組合.Count, 4) = Application.Transpose(Application.Transpose(第一種組合.items)) ' 寫入工作表
- .[J12].Resize(第二種組合.Count, 3) = Application.Transpose(Application.Transpose(第二種組合.items)) ' 寫入工作表
- End With
- ' 釋出物件變數
- Set 第一種組合 = Nothing
- Set 第二種組合 = Nothing
- End Sub
|
|
發表於 2014-5-31 10:26
| 
