GBKEE

回復 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

複製代碼

Kubi

回復 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

複製代碼

Andy2483

回復 9# 准提部林


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

執行前:

下載 (212.49 KB)

2023-5-8 16:21

執行結果:

下載 (224.01 KB)

2023-5-8 16:21

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

Andy2483

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

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