求助VBA统计数据

swl4561255 · 发表于 2024-4-13 19:02

天真无鞋发表于 2024-4-13 18:20
非常感谢2位老师，还有一个小小的问题，请教一下，当引用到相同产品型号的时候，当日的数据能否求和，参考 ...

Sub test()
Range("A4:F100").ClearContents
ar = Sheets("数据源").Range("A1").End(4).Row
arr = Sheets("数据源").Range("A2:R" & ar)
Dim brr(1 To 100, 1 To 6)
myr = Array(12, 9, 16, 18, 4)
For i = 1 To ar - 1
If Int(arr(i, 12)) = [B3] Then
m = m + 1
brr(m, 1) = m
For j = 2 To 6
brr(m, j) = arr(i, myr(j - 2))
Next
End If
Next
If m = 0 Then
MsgBox "未找到该日期对应的数据！"
Exit Sub
End If
Set d = CreateObject("Scripting.Dictionary")
For k = 1 To m
d(brr(k, 2) & "-" & brr(k, 3) & "-" & brr(k, 4) & "-" & brr(k, 5)) = d(brr(k, 2) & "-" & brr(k, 3) & "-" & brr(k, 4) & "-" & brr(k, 5)) + Val(brr(k, 6))
Next
k = d.keys
t = d.items
[A4].Resize(1, 6) = Array("No", "收货日期", "产品型号", "拉别", "工程师", "数量")
For l = 1 To d.Count
Cells(l + 4, 1) = l
Next
[B5].Resize(d.Count, 1) = Application.Transpose(k)
[B5].Resize(d.Count, 1).TextToColumns other:=True, otherchar:="-"
[F5].Resize(d.Count, 1) = Application.Transpose(t)
Set d = Nothing
End Sub

复制代码

ykcbf1100 · 发表于 2024-4-13 19:32

本帖最后由 ykcbf1100 于 2024-4-13 19:39 编辑

天真无鞋发表于 2024-4-13 18:20
非常感谢2位老师，还有一个小小的问题，请教一下，当引用到相同产品型号的时候，当日的数据能否求和，参考 ...

改好了。。。。

ykcbf1100 · 发表于 2024-4-13 19:32

本帖最后由 ykcbf1100 于 2024-4-13 20:27 编辑

代码更新一下，同型号则累计

Sub ykcbf() '//2024.4.13
Dim arr, brr
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
With Sheets("汇总")
rq = Format((.[b3].Value), "yyyy/m/d")
.[a5:f10000].ClearContents
End With
On Error Resume Next
b = [{99,12,9,16,18,4}]
m = 0
With Sheets("数据源")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .[a1].Resize(r, 26)
For i = 2 To UBound(arr)
rq1 = Format(arr(i, 12), "yyyy/m/d")
If rq1 = rq Then
s = arr(i, 9)
If Not d.exists(s) Then
m = m + 1
d(s) = Array(m, arr(i, 12), s, arr(i, 16), arr(i, 18), arr(i, 4))
Else
t = d(s)
t(5) = t(5) + arr(i, 4)
d(s) = t
End If
End If
Next
End With
With Sheets("汇总")
.[a5].Resize(m, 6) = Application.Rept(d.Items, 1)
End With
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

gwjkkkkk · 发表于 2024-4-13 19:44

字典加数组、。。

limonet · 发表于 2024-4-13 20:10

关键字：where+group by

limonet · 发表于 2024-4-13 20:11

Sub limont()
Dim Cn As Object, StrSQL$
Set Cn = CreateObject("Adodb.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
StrSQL = "Select First(F12),F9,First(F16),First(F18),Sum(F4) From [数据源$A2:BM] Where Int(F12)=#" & Range("B3") & "# Group By F9"
Range("B5").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

天真无鞋 · 发表于 2024-4-13 20:19

非常感谢各位

quqiyuan · 发表于 2024-4-13 20:34

yanglinzi · 发表于 2024-4-13 22:05

参与一下。。

yanglinzi · 发表于 2024-4-13 22:05

Sub 汇总()
Dim arr, brr, i, j, r, sa, d
Set d = CreateObject("scripting.dictionary")
With Sheet3
r = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:bm" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 6)
shrq = Sheet8.[b3].Value
For i = 2 To UBound(arr)
rq = CDate(Format(arr(i, 12), "yyyy-mm-dd"))
If shrq = rq Then
sa = rq & "|" & arr(i, 9) & "|" & arr(i, 16) & "|" & arr(i, 18)
d(sa) = d(sa) + arr(i, 4)
End If
Next
For Each ka In d.keys
xa = Split(ka, "|")
n = n + 1
brr(n, 1) = n
brr(n, 2) = xa(0)
brr(n, 3) = xa(1)
brr(n, 4) = xa(2)
brr(n, 5) = xa(3)
brr(n, 6) = d(ka)
Next
With Sheet8
.UsedRange.Cells.Offset(3).ClearContents
.[a5].Resize(n, 6) = brr
End With
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[已解决] 求助VBA统计数据

评分

评分