12
返回列表 上一主題 發帖

[發問] 刪除重複後，尋找重複客戶號碼加總值

Changbanana

帖子
76 
主題
17 
精華
0 
積分
95 
點名
0  
作業系統
windowsxp 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2016-8-19 
最後登錄
2021-5-5 

論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-9-26 11:03 | 只看該作者

[發問] 刪除重複後，尋找重複客戶號碼加總值

請教各位高手~
現有個工作表

已經用
  1. Sub 移除單號重複()
  2. Set dic = CreateObject("scripting.dictionary")
  3. For i = Range("G65536").End(3).Row To 1 Step -1
  4. If dic.Exists(Cells(i, "G").Value) Then
  5. Rows(i).Delete
  6. Else
  7. dic(Cells(i, "G").Value) = ""
  8. End If
  9. Next i
  10. End Sub
複製代碼
刪除單號重複的
但之後需要依客戶編號(A欄)  若有相同的編號 需要加總E欄
(G欄單號可忽略 他是拿來避免單號KEY重複)
想請問該怎麼繼續做呢?
最後想呈現的結果


附件: 測試.zip (510.46 KB)
收藏 分享

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
14#
發表於 2023-5-9 08:18 | 只看該作者
本帖最後由 Andy2483 於 2023-5-9 08:20 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

Option Explicit
Sub TEST_1()
Dim Brr,  Y, i&, j%
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是字典
Brr = Range([G1], [A65536].End(xlUp))
'↑令變數是二維陣列並以儲存格值倒入
For i = 2 To UBound(Brr)
'↑設順迴圈
   If Y(Brr(i, 1)) = "" Then
   '↑這疑問句已經不知不覺將 key是Brr(i, 1),item是"" ,納入在Y字典中了
      Y(Brr(i, 1)) = Y.Count
      '↑索性就依當下key的數量當變數紀錄此key在陣列中的索引列號
      For j = 1 To 7: Brr(Y.Count, j) = Brr(i, j): Next: GoTo i01
      '↑因為是首次納入此key,所以將各欄位值帶入指定位置,覆蓋舊陣列值,
      '↑以上就已經處理了首次值,不必累加金額,所以跳到i01指定位置繼續執行
   End If
   Brr(Y(Brr(i, 1)), 5) = Brr(Y(Brr(i, 1)), 5) + Brr(i, 5)
   '↑如果程序能跑到這裡,代表不是首次,將該key所帶的item調出來(索引列號),
   '讓金額做累加
i01: Next
[J:P].ClearContents
'↑清除結果儲存格舊資料
If Y.Count > 0 Then [J1].Resize(Y.Count, 7) = Brr
'↑如果字典裡有keys!就從[J1]開始貼入Brr陣列局部值
Set Y = Nothing: Erase Brr
'↑釋放變數
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
13#
發表於 2023-5-8 16:24 | 只看該作者
回復 9# 准提部林


    謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案,學習心得註解如下,請前輩再指導

執行前:


執行結果:


Option Explicit
Sub TEST()
Dim Arr, Brr, xD, T&, i&, j%, U&, N&
'↑宣告變數
Arr = Range([A1], [A65536].End(xlUp)(1, 7))
'↑令Arr變數是二維陣列,令以[A1]到 (A欄最後有內容儲存格的右方7格),
'以這範圍儲存格值帶入
'同Arr = Range([G1], [A65536].End(xlUp))
Set xD = CreateObject("scripting.dictionary")
'↑令xD變數是字典
ReDim Brr(1 To UBound(Arr), 1 To 7)
'↑宣告Brr變數是同Arr陣列大小的空陣列
For i = 2 To UBound(Arr)
'↑設順迴圈
    T = Arr(i, 1): U = xD(T)
    '↑令T變數是 客戶編號: '↑令U變數是 以T變數查xD字典的item值
    If U > 0 Then Brr(U, 5) = Brr(U, 5) + Arr(i, 5): GoTo 101
    '↑如果U變數已經紀錄了結果陣列Brr的索引列號?
    '就令在結果陣列Brr正確位置累加 Arr陣列的金額
    '令程序跳到 101標註位置繼續執行
    N = N + 1: U = N: xD(T) = N
    '↑令N變數累加1 :令U變數裝N變數值 :令以T變數當key,item是 N變數
    For j = 1 To 7: Brr(U, j) = Arr(i, j): Next
    '↑設順迴圈將初次符合條件的資料帶入 結果陣列Brr
    'N變數是用來累計索引列號的,U是用來盛裝重複 客戶編號在結果陣列的索引列號
101: Next i
If N > 0 Then [J1].Resize(N, 7) = Brr
'↑如果結果陣列有資料!就從[J1]開始貼入局部的Brr陣列值
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
12#
發表於 2016-10-2 20:23 | 只看該作者
回復 10# Changbanana

若不要求執行速度的話可用這個。
  1. Sub UseFind()
  2.     Dim cell As Range
  3.     Columns("I:O").ClearContents
  4.     [I1].Resize(1, 7) = [A1].Resize(1, 7).Value
  5.     er = 2
  6.     For i = 2 To Range("A65536").End(3).Row
  7.         Set cell = Columns(9).Find(Cells(i, 1).Value, lookat:=xlWhole)
  8.         If cell Is Nothing Then
  9.             Cells(er, 9).Resize(1, 7) = Cells(i, 1).Resize(1, 7).Value
  10.             er = er + 1
  11.         Else
  12.             Cells(cell.Row, 13).Value = Cells(cell.Row, 13).Value + Cells(i, 5).Value
  13.         End If
  14.     Next i
  15. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11#
發表於 2016-10-2 08:53 | 只看該作者
本帖最後由 GBKEE 於 2016-10-2 09:03 編輯

回復 10# Changbanana
不用字典物件 的寫法
  1. Option Explicit
  2. Sub Ex()
  3.     Dim r As Integer, Ar(), i As Integer
  4.     '*******前置作業
  5.     With Range("A:A").CurrentRegion
  6.             'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
  7.             .Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes    '排序
  8.             .Columns(1).AdvancedFilter ACTION:=xlFilterCopy, COPYTORANGE:=Cells(1, Columns.Count), Unique:=True
  9.             '進階篩選:進階不重複資料,至於工作表的最右邊的欄位
  10.     End With
  11.     '************************
  12.     r = Cells(Rows.Count, Columns.Count).End(xlUp).Row                                          '計算 篩選 資料數 (客戶編號)
  13.     ReDim Ar(1 To r)                                                                                                    '重置陣列大小為 (客戶編號)個數
  14.     Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6)))   '表頭 置入陣列
  15.     For i = 2 To r                                                                                                             '迴圈 (客戶編號)
  16.         With Range("A:A")
  17.             .Replace Cells(i, Columns.Count), "=1/0"                                                          '將 (客戶編號) 改為 錯誤值
  18.             With .SpecialCells(xlCellTypeFormulas, xlErrors).Resize(, 6)                           '錯誤值的範圍
  19.                 .Columns(1) = Cells(i, Columns.Count)                                                        ' '將  錯誤值 改回 原 客戶編號
  20.                 Ar(i) = Array(.Cells(1).Value, .Cells(2).Value, .Cells(3).Value, .Cells(4).Value, Application.Sum(.Columns(5)), .Cells(.Rows.Count, 6).Value)                                                                                                                                      'Application.Sum(.Columns(5))  加總(客戶編號)的CASH
  21.             End With
  22.         End With
  23.     Next
  24.     With Range("I1")
  25.         .Resize(r, 6).EntireColumn = ""    '清除舊有資料
  26.         .Resize(r, 6) = Application.Transpose(Application.Transpose(Ar))                     '範圍內導入轉置2次的陣列
  27.     End With
  28.     Cells(1, Columns.Count).EntireColumn = ""    '清除舊有資料
  29. End Sub
  30. '*********************************************************************
  31. Sub Ex1()
  32.     Dim Rng As Range, Ar(), i As Integer
  33.     '*******前置作業
  34.     With Range("A:A").CurrentRegion
  35.             'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
  36.             .Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes    '排序
  37.     End With
  38.     '************************
  39.     i = 1
  40.     ReDim Ar(1 To i)                                                                                                    '重置陣列大小為 (客戶編號)個數
  41.     Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6)))   '表頭 置入陣列
  42.     Set Rng = Range("A2")
  43.     Do While Rng <> ""                                            '客戶編號 <> ""
  44.         i = i + 1
  45.         ReDim Preserve Ar(1 To i)
  46.         With Rng
  47.                 Ar(i) = Array(.Cells(1).Value, .Cells(1, 2).Value, .Cells(1, 3).Value, .Cells(1, 4).Value, .Cells(1, 5).Value, .Cells(.Rows.Count, 6).Value)
  48.         End With
  49.         Do While Rng = Rng.Offset(1)                          '同一 (客戶編號)
  50.             Ar(i)(4) = Ar(i)(4) + Rng.Cells(1, 5)               '加總同一 (客戶編號)的CASH
  51.             Ar(i)(5) = Rng.Cells(2, 6)
  52.             Set Rng = Rng.Offset(1)                                '下一個客戶編號
  53.         Loop
  54.         Set Rng = Rng.Offset(1)                                     '下一個客戶編號
  55.     Loop
  56.     With Range("I1")
  57.         .Resize(, 6).EntireColumn = ""    '清除舊有資料
  58.         .Resize(i, 6) = Application.Transpose(Application.Transpose(Ar))                     '範圍內導入轉置2次的陣列
  59.     End With
  60. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Changbanana

帖子
76 
主題
17 
精華
0 
積分
95 
點名
0  
作業系統
windowsxp 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2016-8-19 
最後登錄
2021-5-5 

論壇贊助勳章
10#
發表於 2016-10-2 00:24 | 只看該作者
回復 8# Kubi

回復 9# 准提部林


  好的~~~謝謝K大和准大~~
  我再慢慢研究
  謝謝你們的回覆^^

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
9#
發表於 2016-9-30 14:12 | 只看該作者
Sub TEST()
Dim Arr, Brr, xD, T&, i&, j%, U&, N&
Arr = Range([A1], [A65536].End(xlUp)(1, 7))
Set xD = CreateObject("scripting.dictionary")
ReDim Brr(1 To UBound(Arr), 1 To 7)
For i = 2 To UBound(Arr)
　　T = Arr(i, 1): U = xD(T)
　　If U > 0 Then Brr(U, 5) = Brr(U, 5) + Arr(i, 5): GoTo 101
　　N = N + 1: U = N: xD(T) = N
　　For j = 1 To 7: Brr(U, j) = Arr(i, j): Next
101: Next i
If N > 0 Then [J1].Resize(N, 7) = Brr
End Sub

同樣邏輯，不同寫法，自行去揣摩∼∼
上網去找 字典檔 及 array陣列 的資料及說明，瞭解了，其它都簡單！
　
　

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
8#
發表於 2016-9-29 15:06 | 只看該作者
回復 7# Changbanana
簡單來說就是從資料端擷取某列資料儲存於二維陣列(arr)中備用。
至於 ReDim 請參閱官方版說明(游標停在ReDim文字中後再按F1鍵)，會比我解釋的更清楚。

TOP

Changbanana

帖子
76 
主題
17 
精華
0 
積分
95 
點名
0  
作業系統
windowsxp 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2016-8-19 
最後登錄
2021-5-5 

論壇贊助勳章
7#
發表於 2016-9-29 09:34 | 只看該作者
回復 6# Kubi


感謝k大的大力相助~
跑出結果是正確的
想請教一下
  1.       ReDim Preserve arr(1 To 7, 1 To n)
  2.             For j = 1 To 7
  3.                 arr(j, n) = Cells(i, j).Value
  4.             Next j
複製代碼
這個用法可不可以解說一下~ 謝謝您:)

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
6#
發表於 2016-9-26 21:38 | 只看該作者
回復 5# Changbanana
試看看。
結果會寫在I:O欄
  1. Sub test()
  2.     Dim arr()
  3.     Dim dic As Object
  4.     Set dic = CreateObject("scripting.dictionary")
  5.     For i = 2 To Range("A65536").End(3).Row
  6.         If dic.Exists(Cells(i, 1).Value) Then
  7.             dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 5).Value
  8.         Else
  9.             dic(Cells(i, 1).Value) = Cells(i, 5).Value
  10.             n = n + 1
  11.             ReDim Preserve arr(1 To 7, 1 To n)
  12.             For j = 1 To 7
  13.                 arr(j, n) = Cells(i, j).Value
  14.             Next j
  15.         End If
  16.     Next i
  17.     For i = 1 To n: arr(5, i) = dic(arr(1, i)): Next i
  18.     Columns("I:O").ClearContents
  19.     [I1].Resize(1, 7) = [A1].Resize(1, 7).Value
  20.     [I2].Resize(n, 7) = Application.Transpose(arr)
  21. End Sub
複製代碼

TOP

        靜思自在 : 布施如播種，以歡喜心滋潤種子，才會發芽。
12
返回列表 上一主題