求助个数据求和问题

小文2014

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

taller

taller

1. Option Explicit
   
2. ' SQL实现比字典更简洁
   
3. Sub SqlQuery()
   
4.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
5.     Set conn = CreateObject("ADODB.Connection")
   
6.     Set rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName                                     '路径
   
8.     Dim rBlank As Range, rCol As Range
   
9.     Set rCol = Sheets("Sheet2").UsedRange.Columns(1)
   
10.     On Error Resume Next
    
11.     Set rBlank = rCol.SpecialCells(Excel.xlBlanks)
    
12.     On Error GoTo 0
    
13.     If Not rBlank Is Nothing Then
    
14.         rBlank.FormulaR1C1 = "=R[-1]C"
    
15.         rCol.Value = rCol.Value
    
16.     End If
    
17.     Select Case Application.Version * 1
    
18.     Case Is <= 11
    
19.         conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
    
20.     Case Is >= 12
    
21.         conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
22.     End Select
    
23.     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.姓名"
    
24.     rst.Open strSQL, conn, 1, 1
    
25. 
    
26.     Set sht = Worksheets.Add(ActiveSheet)
    
27.     With sht
    
28.         For i = 0 To rst.Fields.Count - 1
    
29.             .Cells(1, i + 1) = rst.Fields(i).Name
    
30.         Next i
    
31.         .Range("a2").CopyFromRecordset rst
    
32.     End With
    
33.     With Sheets("Sheet1").UsedRange.Columns(3)
    
34.         .Value = sht.Range(.Address).Value
    
35.     End With
    
36.     Application.DisplayAlerts = False
    
37.     sht.Delete
    
38.     Application.DisplayAlerts = True
    
39.     rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
40. End Sub
    

复制代码

EHGOOD

明天会更好zj

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

baofa2

1. Sub test0() '删除 表一 表二 表三 字样，以免干扰数据装入数组
   
2.   Dim ar, br, cr, dict As Object
   
3.   Dim i As Long, s As String, Flag As Boolean
   
4.   Set dict = CreateObject("Scripting.DictionAry")
   
5.   ar = Range("B1").CurrentRegion.Value
   
6.   For i = 2 To UBound(ar)
   
7.     dict.Add ar(i, 2), Array(i, ar(i, 1))
   
8.     ar(i, 3) = 0
   
9.   Next
   
10.   br = Range("M1").CurrentRegion.Value
    
11.   For i = 1 To UBound(br)
    
12.     dict(br(i, 1)) = dict(br(i, 1)) + Val(br(i, 2))
    
13.   Next
    
14.   br = Range("H1").CurrentRegion.Value
    
15.   For i = 1 To UBound(br)
    
16.     If Len(br(i, 1)) Then
    
17.       s = br(i, 1)
    
18.       Flag = dict.Exists(s)
    
19.       If Flag Then cr = dict(s)
    
20.     End If
    
21.     If Flag Then ar(cr(0), 3) = ar(cr(0), 3) + dict(cr(1) & br(i, 2))
    
22.   Next
    
23.   Range("B1").CurrentRegion.Value = ar
    
24.   Set dict = Nothing
    
25.   Beep
    
26. End Sub
    

复制代码

小文2014

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

LIUZHU

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