返回列表 上一主題 發帖

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

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
1# 跳轉到 »
發表於 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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
2#
發表於 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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
3#
發表於 2020-12-14 15:22 | 顯示全部帖子
本帖最後由 n7822123 於 2020-12-14 15:36 編輯

回復 6# samwang

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

只從第2列往下累加~

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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
4#
發表於 2020-12-15 19:59 | 顯示全部帖子
本帖最後由 n7822123 於 2020-12-15 20:07 編輯

回復 10# v03586

你會用字典物件的話，學Samwang的寫法就可以了

hcm19522大大，也證明了函數可以解決99.99% 的問題

我的寫法必須要先經過排列，不然會有問題~~

回頭看我寫的東西，寫的有點累贅~~~略簡化如下~

Sub 加總()
Dim Arr, PKey$, 刪除列 As Range
Arr = [A1].CurrentRegion    '抓儲存格資料 到 Arr 陣列
Set 刪除列 = Rows(UBound(Arr) + 1)  '這行單純只是避免Union跳出錯誤，先定個範圍
For R& = 2 To UBound(Arr)  '不同的Key紀錄頭一個列號，相同Key做累加，記錄之後要刪除的列號
  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)
     Set 刪除列 = Union(刪除列, Rows(R))
  End If
Next R
[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr  'Arr資料倒回去儲存格
刪除列.Delete   '可改為 刪除列.Select 確認刪除範圍
End Sub
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

        靜思自在 : 唯其尊重自己的人，才更勇於縮小自己。
返回列表 上一主題