12
返回列表 上一主題 發帖

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

v03586

帖子
193 
主題
29 
精華
0 
積分
222 
點名
0  
作業系統
Windows7 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2015-9-18 
最後登錄
2023-4-29 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2020-12-14 02:29 | 只看該作者

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

本帖最後由 v03586 於 2020-12-14 02:31 編輯

請問各位前輩
我有寫一個程式主要是要判斷
假設不同『I欄位』的值, 但相同『J欄位』的值, 則『L欄位』相加在『M欄位』(加總結果)
並保留一個『J欄位』的值, 刪除重複的『J欄位』

如下圖, 但目前執行出來的結果有問題, 請問有前輩可以幫忙指點嗎?


  1. For l = Range("A65536").End(xlUp).Row To 2 Step -1
  2.         If .Cells(l, "I") = .Cells(l - 1, "I") And .Cells(l, "J") = .Cells(l - 1, "J") Then
  3.             .Cells(l - 1, "M") = .Cells(l, "L") + .Cells(l - 1, "L")
  4.             Rows(l).ClearContents
  5.         End If
  6.     Next

  8.     Cells.Select

  10.     Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, _
  11.                       Header:=xlYes
複製代碼
範例.rar (13.09 KB)
收藏 分享

samwang

帖子
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

TOP

hcm19522

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

熱烈參與勳章
3#
發表於 2020-12-14 13:06 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/589509290
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

samwang

帖子
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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
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列往下累加~

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

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
8#
發表於 2020-12-14 15:51 | 只看該作者
回復 7# n7822123


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

TOP

samwang

帖子
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

TOP

v03586

帖子
193 
主題
29 
精華
0 
積分
222 
點名
0  
作業系統
Windows7 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2015-9-18 
最後登錄
2023-4-29 
10#
發表於 2020-12-15 03:13 | 只看該作者
回復 5# n7822123


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

TOP

        靜思自在 : 信心、毅力、勇氣三者具備，則天下沒有做不成的事。
12
返回列表 上一主題