[發問] 重複內容時間加總並刪除重複保留唯一值

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

2^#

發表於 2020-12-14 08:48 | 只看該作者

回復 1# v03586

請測試看看，感謝。

Sub TEST()
Dim Arr, xD, T, N&, j%, NR&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([M1], [A65536].End(3))
For i = 1 To UBound(Arr)
T = Arr(i, 9) & Arr(i, 10)
If xD.Exists(T & "") Then
      NR = xD(T & "")
      Arr(NR, 13) = Arr(NR, 13) + Arr(i, 12)
Else
      N = N + 1
      xD(T & "") = N
      For j = 1 To 12: Arr(N, j) = Arr(i, j): Next
  End If
Next
Range("A1:M" & [A65536].End(3).Row) = ""
Arr(1, 13) = "TIME"
[A1].Resize(N, 13) = Arr
End Sub

hcm19522

https://blog.xuite.net/hcm19522/twblog/589509290

帖子: 1387
主題: 4
精華: 0
積分: 1397
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-11-25

熱烈參與勳章

3^#

發表於 2020-12-14 13:06 | 只看該作者

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

4^#

發表於 2020-12-14 13:32 | 只看該作者

回復 2# samwang

你忘記累加頭一列了喔~

If xD.Exists(T & "") Then
      NR = xD(T & "")
      Arr(NR, 13) = Arr(NR, 13) + Arr(i, 12)
Else
      N = N + 1
      xD(T & "") = N
      For j = 1 To 12: Arr(N, j) = Arr(i, j): Next
      Arr(N, 13) = Arr(N, 12)
End If

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

5^#

發表於 2020-12-14 13:50 | 只看該作者

回復 1# v03586

我提供一個比較 "直覺" 且不用字典物件的寫法給你

Arr陣列只是為了加快運算速度 (用 Cell物件運算會較慢)

若看不懂，只要把Arr 改成 Cell 你就懂了 Ex: Arr(R,12) => Cell(R,12)

程式如下

Sub 加總()
Dim Arr, R_Del_Arr, PKey$, 刪除列 As Range
Arr = [A1].CurrentRegion '抓儲存格資料到 Arr 陣列
'不同的Key紀錄頭一個列號，相同Key做累加，記錄之後要刪除的列號
For R& = 2 To UBound(Arr)
  Key$ = Arr(R, 9) & Arr(R, 10)
  If Key <> PKey Then
R0& = R: PKey = Key
Arr(R, 13) = Arr(R, 12)
  Else
Arr(R0, 13) = Arr(R0, 13) + Arr(R, 12)
R_Del$ = R_Del$ & "," & R
  End If
Next R
R_Del_Arr = Split(Mid(R_Del, 2), ",")
[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr  'Arr資料倒回去儲存格
'刪除重複列
For Each Rd In R_Del_Arr
  If 刪除列 Is Nothing Then
Set 刪除列 = Rows(Rd)
  Else
Set 刪除列 = Union(刪除列, Rows(Rd))
  End If
Next
刪除列.Delete '可改為刪除列.Select 確認刪除範圍
End Sub

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

6^#

發表於 2020-12-14 14:24 | 只看該作者

回復 4# n7822123

你忘記累加頭一列了喔~

If xD.Exists(T & "") Then
      NR = xD(T & "")
      Arr(NR, 13) = Arr(NR, 13) + Arr(i, 12)
   Else
      N = N + 1
      xD(T & "") = N
      For j = 1 To 12: Arr(N, j) = Arr(i, j): Next
      Arr(N, 13) = Arr(N, 12)
End If

請問n7822123 您提問題忘記累加頭一列了喔~ ，是原本我回覆的那一列嗎?
感謝指教。

Range("A1:M" & [A65536].End(3).Row) = ""
Arr(1, 13) = "TIME"
[A1].Resize(N, 13) = Arr
End Sub

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

7^#

發表於 2020-12-14 15:22 | 只看該作者

本帖最後由 n7822123 於 2020-12-14 15:36 編輯

回復 6# samwang

是阿，你的程式算出來的值~ 沒累加到頭一列~

只從第2列往下累加~

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

8^#

發表於 2020-12-14 15:51 | 只看該作者

回復 7# n7822123

感謝指導，真的很粗心大意，感恩。

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

9^#

發表於 2020-12-14 16:17 | 只看該作者

回復 1# v03586

更新程式碼如下，謝謝

Sub TEST_2()
Dim Arr, xD, T, N%, j%, NR
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([M1], [A65536].End(3))
For i = 1 To UBound(Arr)
T = Arr(i, 9) & Arr(i, 10)
If xD.Exists(T & "") Then
      NR = xD(T & "")
      Arr(NR, 13) = Arr(NR, 13) + Arr(i, 12)
Else
      N = N + 1
      xD(T & "") = N
      For j = 1 To 12: Arr(N, j) = Arr(i, j): Next
      Arr(N, 13) = Arr(N, 12)
  End If
Next
Range("A1:M" & [A65536].End(3).Row) = ""
Arr(1, 13) = "TIME"
[A1].Resize(N, 13) = Arr
End Sub

v03586

帖子: 193
主題: 29
精華: 0
積分: 222
點名: 0
作業系統: Windows7
軟體版本: OFFICE2013
閱讀權限: 20
註冊時間: 2015-9-18
最後登錄: 2023-4-29

10^#

發表於 2020-12-15 03:13 | 只看該作者

回復 5# n7822123

感謝前輩們的提醒, 真的陣列跑快非常多, 求學時期陣列真的把我搞慘了, 出社會後才發現真正實用的地方!!