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 時間: 2022-12-29 16:36
請測試看看，謝謝
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 時間: 2022-12-30 09:45
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 時間: 2022-12-30 16:18
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 時間: 2023-3-1 09:26
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作者: singo1232001 時間: 2023-3-1 10:04
'很硬要的縮到極限
Sub TEST()
Set CN = CreateObject("adodb.connection"): V = Application.Version: [F:H].ClearContents
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
CN.Open V & "Data Source=" & ThisWorkbook.FullName
q = "select 日期,產品,sum(數量)from[工作表2$a1:C]group by 日期,產品 having 日期 is not null"
Set RS = CN.Execute(q): [F1:H1] = [A1:C1].Value: [F2].CopyFromRecordset RS
End Sub
