刪除重複後，尋找重複客戶號碼加總值 - Excel程式區

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 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
不用字典物件的寫法

Option Explicit
Sub Ex()
Dim r As Integer, Ar(), i As Integer
'*******前置作業
With Range("A:A").CurrentRegion
'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
.Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes '排序
.Columns(1).AdvancedFilter ACTION:=xlFilterCopy, COPYTORANGE:=Cells(1, Columns.Count), Unique:=True
'進階篩選:進階不重複資料,至於工作表的最右邊的欄位
End With
'************************
r = Cells(Rows.Count, Columns.Count).End(xlUp).Row '計算篩選資料數 (客戶編號)
ReDim Ar(1 To r) '重置陣列大小為 (客戶編號)個數
Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6))) '表頭置入陣列
For i = 2 To r '迴圈 (客戶編號)
With Range("A:A")
.Replace Cells(i, Columns.Count), "=1/0" '將 (客戶編號) 改為錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors).Resize(, 6) '錯誤值的範圍
.Columns(1) = Cells(i, Columns.Count) ' '將錯誤值改回原客戶編號
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
End With
End With
Next
With Range("I1")
.Resize(r, 6).EntireColumn = "" '清除舊有資料
.Resize(r, 6) = Application.Transpose(Application.Transpose(Ar)) '範圍內導入轉置2次的陣列
End With
Cells(1, Columns.Count).EntireColumn = "" '清除舊有資料
End Sub
'*********************************************************************
Sub Ex1()
Dim Rng As Range, Ar(), i As Integer
'*******前置作業
With Range("A:A").CurrentRegion
'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
.Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes '排序
End With
'************************
i = 1
ReDim Ar(1 To i) '重置陣列大小為 (客戶編號)個數
Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6))) '表頭置入陣列
Set Rng = Range("A2")
Do While Rng <> "" '客戶編號 <> ""
i = i + 1
ReDim Preserve Ar(1 To i)
With Rng
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)
End With
Do While Rng = Rng.Offset(1) '同一 (客戶編號)
Ar(i)(4) = Ar(i)(4) + Rng.Cells(1, 5) '加總同一 (客戶編號)的CASH
Ar(i)(5) = Rng.Cells(2, 6)
Set Rng = Rng.Offset(1) '下一個客戶編號
Loop
Set Rng = Rng.Offset(1) '下一個客戶編號
Loop
With Range("I1")
.Resize(, 6).EntireColumn = "" '清除舊有資料
.Resize(i, 6) = Application.Transpose(Application.Transpose(Ar)) '範圍內導入轉置2次的陣列
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

Kubi

中學生 Rank: 2

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

12^#

發表於 2016-10-2 20:23 | 只看該作者

回復 10# Changbanana

若不要求執行速度的話可用這個。

Sub UseFind()
Dim cell As Range
Columns("I:O").ClearContents
[I1].Resize(1, 7) = [A1].Resize(1, 7).Value
er = 2
For i = 2 To Range("A65536").End(3).Row
Set cell = Columns(9).Find(Cells(i, 1).Value, lookat:=xlWhole)
If cell Is Nothing Then
Cells(er, 9).Resize(1, 7) = Cells(i, 1).Resize(1, 7).Value
er = er + 1
Else
Cells(cell.Row, 13).Value = Cells(cell.Row, 13).Value + Cells(i, 5).Value
End If
Next i
End Sub

複製代碼

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

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

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

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

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

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]