Board logo

標題: [發問] 重複內容時間加總並刪除重複保留唯一值 [打印本頁]

作者: v03586    時間: 2020-12-14 02:29     標題: 重複內容時間加總並刪除重複保留唯一值

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

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

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



[attach]32802[/attach]
  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

  7.     Cells.Select

  8.     Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, _
  9.                       Header:=xlYes
複製代碼
[attach]32803[/attach]
作者: samwang    時間: 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    時間: 2020-12-14 13:06

https://blog.xuite.net/hcm19522/twblog/589509290
作者: n7822123    時間: 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    時間: 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

作者: samwang    時間: 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    時間: 2020-12-14 15:22

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

回復 6# samwang

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

只從第2列往下累加~


[attach]32804[/attach]
作者: samwang    時間: 2020-12-14 15:51

回復 7# n7822123


感謝指導,真的很粗心大意,感恩。
作者: samwang    時間: 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    時間: 2020-12-15 03:13

回復 5# n7822123


    感謝前輩們的提醒, 真的陣列跑快非常多, 求學時期陣列真的把我搞慘了, 出社會後才發現真正實用的地方!!
作者: v03586    時間: 2020-12-15 03:14

回復 9# samwang


    感謝前輩的指導, 兩種方式都有學起來!! 以後有問題再請前輩多多指教!!
作者: n7822123    時間: 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

作者: Andy2483    時間: 2023-3-24 15:09

回復 1# v03586


    謝謝前輩發表此主題與範例,謝謝各位前輩,謝謝論壇
後學藉此帖練習陣列與字典,學習的解決方案如下,請前輩參考
請各位前輩指教

執行前:
[attach]36024[/attach]

執行結果:
[attach]36025[/attach]


Option Explicit
Sub TEST_2()
Dim Brr, Y, T$, C%, j%, i&, xA As Range
'↑宣告變數:(Brr,Y)是通用型變數,T是字串變數,
'(C,j)是短整數,i是長整數,xA是儲存格變數

Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Set xA = Range([M1], Cells(Rows.Count, 1).End(3)): Brr = xA
'↑令xA這儲存格變數是 [M1]擴展到A欄最後有內容儲存格
'令Brr這通用型變數是 二維陣列,以xA變數(儲存格值)帶入

C = UBound(Brr, 2)
'↑令C這短整數變數是 Brr陣列橫向最大索引欄號
For i = 2 To UBound(Brr)
'↑設順迴圈!i從2到 Brr陣列縱向最大索引列號
   T = Brr(i, 9) & "|" & Brr(i, 10)
   '↑令T這字串變數是 i迴圈列第9欄Brr陣列值 連接 "|",
   '再連接 i迴圈列第10欄Brr陣列值,所組成的新字串

   If Y(T) = "" Then
   '↑如果T變數查Y字典的item值是空字元?
   '(這問句已經將 T變數當key,item是空字元,納入Y字典了,已增加個新key)

      Y(T) = Y.Count + 1
      '↑令 T變數當key,item是 Y字典key數量 + 1
      For j = 1 To C - 1: Brr(Y(T), j) = Brr(i, j): Next
      '↑設順迴圈!j從1到 C變數-1,陸續將該列各欄值帶入指定列同欄位置
      Brr(Y(T), 13) = Brr(Y(T), 12): GoTo i01
      '↑令(T變數查Y字典item值)列第13欄Brr陣列值是
      '(T變數查Y字典item值)列第12欄Brr陣列值
      '令程序跳到 i01標示位置繼續執行

   End If
   Brr(Y(T), 13) = Brr(Y(T), 13) + Brr(i, 12)
   '↑令(T變數查Y字典item值)列第13欄Brr陣列值是
   '自身值 + (T變數查Y字典item值)列第12欄Brr陣列值

i01: Next
ActiveSheet.UsedRange.Clear
'↑令有使用儲存格範圍做清除
xA.Resize(Y.Count + 1, C) = Brr
'↑令xA變數(儲存格)第1格擴展向下 Y字典key數量+1列,
'向右擴展C變數欄,這範圍儲存格值以Brr陣列值帶入

Set Y = Nothing: Set xA = Nothing: Erase Brr
'釋放變數
End Sub




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)