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

Changbanana 發表於 2016-9-26 11:03

刪除重複後，尋找重複客戶號碼加總值

請教各位高手~
現有個工作表
[attach]25346[/attach]
已經用[code]Sub 移除單號重複()
Set dic = CreateObject("scripting.dictionary")
For i = Range("G65536").End(3).Row To 1 Step -1
If dic.Exists(Cells(i, "G").Value) Then
Rows(i).Delete
Else
dic(Cells(i, "G").Value) = ""
End If
Next i
End Sub[/code]刪除單號重複的
但之後需要依客戶編號(A欄) 若有相同的編號需要加總E欄
(G欄單號可忽略他是拿來避免單號KEY重複)
想請問該怎麼繼續做呢?
最後想呈現的結果
[attach]25347[/attach]

附件:[attach]25348[/attach]

Kubi 發表於 2016-9-26 14:09

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94194&ptid=18434]1#[/url] [i]Changbanana[/i] [/b]

看起來你的索引KEY除了客戶編號之外，還須包括B欄的sell作為KEY值，才合乎你想呈現的結果吧？

Changbanana 發表於 2016-9-26 14:22

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94200&ptid=18434]2#[/url] [i]Kubi[/i] [/b]

抱歉抱歉
B欄忘記改了
KEY 值只有A欄
[attach]25351[/attach]

10301==>小明
10302==>大雄
10303==>筱華

其他資料可以忽略
主要KEY 值是A 欄 A欄一樣的加總E欄(合併)

Kubi 發表於 2016-9-26 15:25

[i=s] 本帖最後由 Kubi 於 2016-9-26 15:34 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94203&ptid=18434]3#[/url] [i]Changbanana[/i] [/b]
可是編號10302包括大雄與小明，如何區別？

Changbanana 發表於 2016-9-26 20:04

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94204&ptid=18434]4#[/url] [i]Kubi[/i] [/b]

10302一定是大雄

檔案沒改到
更新過的檔案:[attach]25362[/attach]

Kubi 發表於 2016-9-26 21:38

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94209&ptid=18434]5#[/url] [i]Changbanana[/i] [/b]
試看看。
結果會寫在I:O欄[code]Sub test()
Dim arr()
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 2 To Range("A65536").End(3).Row
      If dic.Exists(Cells(i, 1).Value) Then
         dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 5).Value
      Else
         dic(Cells(i, 1).Value) = Cells(i, 5).Value
         n = n + 1
         ReDim Preserve arr(1 To 7, 1 To n)
         For j = 1 To 7
            arr(j, n) = Cells(i, j).Value
         Next j
      End If
Next i
For i = 1 To n: arr(5, i) = dic(arr(1, i)): Next i
Columns("I:O").ClearContents
[I1].Resize(1, 7) = [A1].Resize(1, 7).Value
[I2].Resize(n, 7) = Application.Transpose(arr)
End Sub[/code]

Changbanana 發表於 2016-9-29 09:34

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94214&ptid=18434]6#[/url] [i]Kubi[/i] [/b]

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

Kubi 發表於 2016-9-29 15:06

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94285&ptid=18434]7#[/url] [i]Changbanana[/i] [/b]
簡單來說就是從資料端擷取某列資料儲存於二維陣列(arr)中備用。
至於 ReDim 請參閱官方版說明(游標停在ReDim文字中後再按F1鍵)，會比我解釋的更清楚。

准提部林 發表於 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陣列的資料及說明，瞭解了，其它都簡單！
　
　

Changbanana 發表於 2016-10-2 00:24

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94295&ptid=18434]8#[/url] [i]Kubi[/i] [/b]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94335&ptid=18434]9#[/url] [i]准提部林[/i] [/b]

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

GBKEE 發表於 2016-10-2 08:53

[i=s] 本帖最後由 GBKEE 於 2016-10-2 09:03 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94361&ptid=18434]10#[/url] [i]Changbanana[/i] [/b]
不用字典物件的寫法[code]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[/code]

Kubi 發表於 2016-10-2 20:23

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94361&ptid=18434]10#[/url] [i]Changbanana[/i] [/b]

若不要求執行速度的話可用這個。[code]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[/code]

Andy2483 發表於 2023-5-8 16:24

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=94335&ptid=18434]9#[/url] [i]准提部林[/i] [/b]

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

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

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

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

Andy2483 發表於 2023-5-9 08:18

[i=s] 本帖最後由 Andy2483 於 2023-5-9 08:20 編輯 [/i]

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

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

頁: [1]

麻辣家族討論版版's Archiver

刪除重複後，尋找重複客戶號碼加總值