求助个数据求和问题

小文2014 · 发表于 2024-5-11 22:34

求助个数据求和问题，各位置老师帮忙看下。。。。

taller · 发表于 2024-5-12 06:16

taller · 发表于 2024-5-12 06:17

Option Explicit
' SQL实现比字典更简洁
Sub SqlQuery()
Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
PathStr = ThisWorkbook.FullName '路径
Dim rBlank As Range, rCol As Range
Set rCol = Sheets("Sheet2").UsedRange.Columns(1)
On Error Resume Next
Set rBlank = rCol.SpecialCells(Excel.xlBlanks)
On Error GoTo 0
If Not rBlank Is Nothing Then
rBlank.FormulaR1C1 = "=R[-1]C"
rCol.Value = rCol.Value
End If
Select Case Application.Version * 1
Case Is <= 11
conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
Case Is >= 12
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
End Select
strSQL = "select e.序号, e.姓名, f.qua as 数量 from [Sheet1$] as e left outer join ( select c.姓名, sum(d.数量) as qua from (select b.姓名, a.序号 & b.产品 as product from [Sheet1$] as a inner join [Sheet2$] as b on a.姓名=b.姓名) as c inner join [Sheet3$] as d on d.产品=c.product group by c.姓名) as f on e.姓名 = f.姓名"
rst.Open strSQL, conn, 1, 1
Set sht = Worksheets.Add(ActiveSheet)
With sht
For i = 0 To rst.Fields.Count - 1
.Cells(1, i + 1) = rst.Fields(i).Name
Next i
.Range("a2").CopyFromRecordset rst
End With
With Sheets("Sheet1").UsedRange.Columns(3)
.Value = sht.Range(.Address).Value
End With
Application.DisplayAlerts = False
sht.Delete
Application.DisplayAlerts = True
rst.Close: conn.Close: Set conn = Nothing: Set rst = Nothing
End Sub

复制代码

EHGOOD · 发表于 2024-5-12 08:34

本帖最后由 EHGOOD 于 2024-5-12 09:57 编辑

明天会更好zj · 发表于 2024-5-12 08:54

建议你把表格做规范点，1牛1猪的，感觉太随意了。最好能上真实的数据表。

baofa2 · 发表于 2024-5-12 09:26

Sub test0() '删除表一表二表三字样，以免干扰数据装入数组
Dim ar, br, cr, dict As Object
Dim i As Long, s As String, Flag As Boolean
Set dict = CreateObject("Scripting.DictionAry")
ar = Range("B1").CurrentRegion.Value
For i = 2 To UBound(ar)
dict.Add ar(i, 2), Array(i, ar(i, 1))
ar(i, 3) = 0
Next
br = Range("M1").CurrentRegion.Value
For i = 1 To UBound(br)
dict(br(i, 1)) = dict(br(i, 1)) + Val(br(i, 2))
Next
br = Range("H1").CurrentRegion.Value
For i = 1 To UBound(br)
If Len(br(i, 1)) Then
s = br(i, 1)
Flag = dict.Exists(s)
If Flag Then cr = dict(s)
End If
If Flag Then ar(cr(0), 3) = ar(cr(0), 3) + dict(cr(1) & br(i, 2))
Next
Range("B1").CurrentRegion.Value = ar
Set dict = Nothing
Beep
End Sub

复制代码

小文2014 · 发表于 2024-5-12 10:47

谢谢以上几位大佬。。。。。

LIUZHU · 发表于 2024-5-12 11:47

感觉这个问题的需求不是很明确，最终的结果是需要绿色区域和蓝色区域吗？还是只需要绿色区域？

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