[發問] 2條件下做資料整理相加

willeddie

各位大前輩你好
目前初學著，感謝指教

下載 (14.93 KB)

2022-12-29 10:53

要從左邊沒有整理過的資料，根據同日期產品的做相加總數成右邊的表格
感謝指教

Andy2483

回復 1# willeddie


    謝謝前輩發表此主題
後學藉此帖練習字典.二維陣列與一維陣列,過程.結果與程式碼如下,請試試看是否符合需求

亂數產生的範例:

下載 (116.29 KB)

2022-12-29 14:06

執行結果:

下載 (145.27 KB)

2022-12-29 14:06

Option Explicit
Sub 陣列與字典練習_2條件下做資料整理相加_FG欄排序()
Dim Y, Z, V, Arr, i, T(3)
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set V = CreateObject("Scripting.Dictionary")
Arr = Range([C2], [A65536].End(3))
For i = 1 To UBound(Arr)
   T(1) = DateValue(Arr(i, 1))
   T(2) = Arr(i, 2)
   T(3) = Arr(i, 3)
   T(0) = T(1) & "|" & T(2)
   Y(T(0)) = Y(T(0)) + T(3)
   Z(T(0)) = T(1)
   V(T(0)) = T(2)
Next
[F:H].ClearContents
[F2].Resize(Z.Count, 1) = Application.Transpose(Z.Items)
[G2].Resize(V.Count, 1) = Application.Transpose(V.Items)
[H2].Resize(Y.Count, 1) = Application.Transpose(Y.Items)
With [F2].Resize(Z.Count, 3)
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   Key2:=.Item(2), Order2:=xlAscending, _
   Header:=xlNo, Orientation:=xlTopToBottom
End With
[F1:H1] = [{"日期","產品","數量"}]
Set Y = Nothing
Set Z = Nothing
Set V = Nothing
Set Arr = Nothing
Erase T
End Sub

Sub 亂數製作範例_日期_產品_數量()
[A:C].ClearContents
[A1:C1] = [{"日期","產品","數量"}]
With [A2:A30]
   .Formula = "=IF(RAND()>.5,TODAY()+INT(RAND()*5),TODAY()+INT(RAND()*-5))"
   .Offset(, 1).Formula = "=MID(""ABC"",MOD(INT(RAND()*100),3)+1,1)"
   .Offset(, 2).Formula = "=IF(RAND()>.1,INT(RAND()*100),INT(RAND()*-100))"
   .Resize(, 3).Value = .Resize(, 3).Value
End With
End Sub

lee88

回復 2# Andy2483

1. Option Explicit
   
2. 
   
3. Sub 資料整理相加()
   
4.     Dim D As Object, E As Range, B As Variant
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     For Each E In [A1:A30]     '  亂數製作範例的存放處
   
7.         If Not D.exists(E & UCase(E.Range("b1"))) Then   '字典物件的key(關鍵字)   不存在時  (日期&產品)
   
8.             D(E & E.Range("b1")) = Array(E.Text, UCase(E.Range("b1")), E.Range("c1").Text)
   
9.             '字典物件(關鍵字)的item(內容)  為一維陣列
   
10.         Else
    
11.             B = D(E & UCase(E.Range("b1")))  '讀取字典物件(關鍵字)的item(內容)
    
12.             B(2) = B(2) + E.Range("c1")              '數量相加
    
13.             D(E & UCase(E.Range("b1"))) = B   '字典物件(關鍵字)= 指定內容
    
14.         End If
    
15.     Next
    
16.     With [H1].Resize(D.Count, 3)   '整理相加存放處
    
17.         .Value = Application.Transpose(Application.Transpose(D.ItemS)) '轉置一維陣列維二維陣列
    
18.         .Sort KEY1:=.Cells(1), Order1:=1, KEY2:=.Cells(2), Order2:=1, Header:=xlYes
    
19.     End With
    
20. End Sub

複製代碼

samwang

回復 1# willeddie

請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [c65536].End(3))
For i = 1 To UBound(Arr)
    T = Arr(i, 1) & "|" & Arr(i, 2)
    If xD.Exists(T) Then
        Arr(xD(T), 3) = Arr(xD(T), 3) + Arr(i, 3)
    Else
        n = n + 1: xD(T) = n
        For j = 1 To 3: Arr(n, j) = Arr(i, j): Next
  End If
Next
With [f1].Resize(n, 3)
    .Value = Arr
   .Sort Key1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
End With
End Sub

hcm19522

https://blog.xuite.net/hcm19522/twblog/590673340

Andy2483

回復 2# Andy2483


    回復自己複習心得註解
Option Explicit
Sub 陣列與字典練習_2條件下做資料整理相加_FG欄排序()
Dim Y, Z, V, Arr, i&, T(3)
'↑宣告變數:(Y,Z,V,Arr)是通用型變數,i是長整數,T是一維陣列T(0)~T(3)
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set V = CreateObject("Scripting.Dictionary")
'↑令Y,Z,V各是字典
Arr = Range([C2], [A65536].End(3))
'↑令Arr是二維陣列!以[C2]到A欄最後有內容儲存格,這範圍儲存格值倒入
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到Arr陣列最列大索引號數
   T(1) = DateValue(Arr(i, 1))
   '↑令1索引號T陣列值是 i迴圈列1欄Arr陣列值轉日期格式
   T(2) = Arr(i, 2)
   '↑令2索引號T陣列值是 i迴圈列2欄Arr陣列值
   T(3) = Arr(i, 3)
   '↑令3索引號T陣列值是 i迴圈列3欄Arr陣列值
   T(0) = T(1) & "|" & T(2)
   '↑令0索引號T陣列值是 1索引號T陣列值連接 "|" 再連接2索引號T陣列值
   Y(T(0)) = Y(T(0)) + T(3)
   '↑令以0索引號T陣列值為Key,item是自身+3索引號T陣列值,倒入Y字典
   Z(T(0)) = T(1)
   '↑令以0索引號T陣列值為Key,1索引號T陣列值,倒入Z字典
   V(T(0)) = T(2)
   '↑令以0索引號T陣列值為Key,2索引號T陣列值,倒入V字典
Next
[F:H].ClearContents
'↑清除F:H欄儲存格內容
[F2].Resize(Z.Count, 1) = Application.Transpose(Z.ItemS)
'↑令[F2]擴展向下Z字典數 向右不擴展範圍儲存格以Z字典的item轉置後倒入
[G2].Resize(V.Count, 1) = Application.Transpose(V.ItemS)
'↑類推
[H2].Resize(Y.Count, 1) = Application.Transpose(Y.ItemS)
'↑類推
With [F2].Resize(Z.Count, 3)
'↑以下是 關於[F2]擴展向下Z字典數 向右3欄範圍儲存格
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   KEY2:=.Item(2), Order2:=xlAscending, _
   Header:=xlNo, Orientation:=xlTopToBottom
    '↑令以儲存格集第1欄做第一層做無標題列的上下順排序,第2欄同時做第二層上下順排序
End With
[F1:H1] = [{"日期","產品","數量"}]
'↑令F1到H1之間的儲存格以字串帶入
Set Y = Nothing
Set Z = Nothing
Set V = Nothing
Set Arr = Nothing
Erase T
'↑釋放變數
End Sub

Andy2483

回復 3# lee88


    謝謝論壇,謝謝前輩
後學藉此帖學習到不同語法,心得註解如下,謝謝前輩

Option Explicit
Sub 資料整理相加_lee88()
Dim D As Object, E As Range, B As Variant
'↑宣告變數:D是物件變數,E是儲存格變數,B是通用型變數
Set D = CreateObject("Scripting.Dictionary")
'↑令D是 字典
For Each E In [A1:A30]
'↑設迴圈!令E是 [A1:A30]的儲存格之一
   If Not D.exists(E & UCase(E.Range("b1"))) Then
   '↑如果 以E變數儲存格值連接(右1格儲存格值轉英文大寫)字串,用Exists 方法判定,If是True
      D(E & E.Range("b1")) = Array(E.Text, UCase(E.Range("b1")), E.Range("c1").Text)
      '字典物件(關鍵字)的item(內容)  為一維陣列
      '↑令以E變數儲存格值連接(右1格儲存格值)字串當key,ITEM是一維陣列,
      '帶入(E變數儲存格值,E變數儲存格右1格儲存格值轉英文大寫,E變數儲存格右2格儲存格值)
      Else
         B = D(E & UCase(E.Range("b1")))
         '讀取字典物件(關鍵字)的item(內容)
         '↑令B這通用型變數是 以E變數儲存格值連接(右1格儲存格值轉英文大寫)字串查D字典的item,
         '這item是一維陣列
         B(2) = B(2) + E.Range("c1")
         '數量相加
         '↑令這一維陣列的2索引號陣列值自身值+ E變數儲存格右2格儲存格值
         D(E & UCase(E.Range("b1"))) = B
         '字典物件(關鍵字)= 指定內容
         '↑令這一維陣列再放回字典
   End If
Next
With [F1].Resize(D.Count, 3)
'整理相加存放處
'↑以下是 關於[F1]擴展向下D字典數 向右3欄範圍儲存格
   .Value = Application.Transpose(Application.Transpose(D.ItemS))
   '轉置一維陣列維二維陣列
   '↑這範圍儲存格值以 D字典的item轉置2次帶入
   .Sort KEY1:=.Cells(1), Order1:=1, KEY2:=.Cells(2), Order2:=1, Header:=xlYes
   '↑令以儲存格集第1欄做第一層做有標題列的上下順排序,第2欄同時做第二層上下順排序
End With
End Sub

Andy2483

回復 4# samwang


    謝謝前輩
後學藉此帖做複習以字典紀錄結果資料列號的方式處理 統計結果
心得註解如下,謝謝前輩

Option Explicit
Sub test_samwang()
Dim Arr, xD, T$, n%, i&, j&
'↑宣告變數:(Arr,xD)是通用型變數,T是字串變數,n是短整數,(i,j)是長整數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是 字典
Arr = Range([a1], [c65536].End(3))
'↑令Arr是二維陣列!以[A1]到C欄最後有內容儲存格範圍儲存格值倒入
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到Arr陣列縱向最大索引列號數
    T = Arr(i, 1) & "|" & Arr(i, 2)
    '↑令T是i迴圈列1欄Arr陣列值連接 "|" 再連接 i迴圈列2欄Arr陣列值
    If xD.exists(T) Then
    '↑如果以T變數 用Exists 方法查xD字典判定是True
        Arr(xD(T), 3) = Arr(xD(T), 3) + Arr(i, 3)
        '↑令以T變數查xD字典得到的item數字為列3欄Arr陣列值是自身值+i迴圈列3欄Arr陣列值
    Else
    '↑以下是If條件不成立才執行的程序
        n = n + 1: xD(T) = n
        '↑令n這短整數變數累加1 :令以T變數當key,item是n變數倒入xD字典
        For j = 1 To 3: Arr(n, j) = Arr(i, j): Next
        '↑設順迴圈!j從1到3 :n變數列j迴圈欄Arr陣列值是 i變數列j迴圈欄Arr陣列值
  End If
Next
With [F1].Resize(n, 3)
'↑以下是 關於[F1]擴展向下n變數列 向右3欄範圍儲存格
    .Value = Arr
    '↑這範圍儲存格值以Arr陣列值帶入
   .Sort KEY1:=.Item(1), Order1:=1, _
         KEY2:=.Item(2), Order2:=1, Header:=1
   '↑令以儲存格集第1欄做第一層做有標題列的上下順排序,第2欄同時做第二層上下順排序
End With
End Sub

singo1232001

回復 1# willeddie


    Sub TEST()
Set cn = CreateObject("adodb.connection")
C = ".0; Data Source=" & ThisWorkbook.FullName
Select Case Application.Version
Case Is < 12: cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8" & C
Case Else: cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12" & C: End Select

q = "select 日期,產品,sum(數量) as 數量 from [工作表2$a1:C] "
q = q & "group by 日期,產品  having 日期 is not null "

With Sheets("工作表2"): .Range("F:H").ClearContents
Set rs = cn.Execute(q)
For i = 0 To rs.Fields.Count - 1 '取標題，如果不要可省略
    .Cells(1, i + 6) = rs.Fields(i).Name
Next
.Cells(2, 6).CopyFromRecordset rs : End With
End Sub

singo1232001

回復 9# singo1232001

Sub TEST()
Select Case Application.Version
Case Is < 12: B = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8"
Case Else: B = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12": End Select
Set cn = CreateObject("adodb.connection")
cn.Open B & ".0; Data Source=" & ThisWorkbook.FullName
q = "select 日期,產品,sum(數量)from[工作表2$a1:C]group by 日期,產品 having 日期 is not null"
Set rs = cn.Execute(q)
[F:H].ClearContents: [F1:H1] = [A1:C1].Value
[F2].CopyFromRecordset rs
End Sub