如何用VBA实现多条件求和？

xyuer

急用，谢谢各位大侠！

mineshine

1. Sub Total()
   
2. Dim conn As Object, sql$, i As Long
   
3. Set conn = CreateObject("adodb.connection")
   
4. conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName
   
5. With Sheets("Sheet2")
   
6.     .Range("D2:D65536").ClearContents
   
7.     For i = 2 To .[A65536].End(xlUp).Row
   
8.         sql = "select sum(f3) from (select * from [Sheet1$A2:C" & Sheet1.[A65536].End(xlUp).Row & "]  union select * from [Sheet1$D:F" & Sheet1.[D65536].End(xlUp).Row & "]) where f1>=#" & .Cells(i, 1) & "# and f1<=#" & .Cells(i, 2) & "# and f2='" & .Cells(i, 3) & "'"
   
9.         .Cells(i, 4).CopyFromRecordset conn.Execute(sql)
   
10.     Next i
    
11. End With
    
12. conn.Close
    
13. Set conn = Nothing
    
14. End Sub

复制代码

zhaogang1960

mineshine坛友给出了ADO方法，下面是数组+字典法，请参考：

1. Sub Macro1()
   
2.     Dim arr, brr, crr(), d As Object, i&, j&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("A2:C" & Range("A65536").End(xlUp).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         d(arr(i, 3)) = i
   
7.     Next
   
8.     ReDim crr(1 To UBound(arr), 0)
   
9.     brr = Sheets("Sheet1").[a1].CurrentRegion
   
10.     For i = 2 To UBound(brr)
    
11.         For j = 1 To 6 Step 3
    
12.             If d.Exists(brr(i, j + 1)) Then
    
13.                 If brr(i, j) >= arr(d(brr(i, j + 1)), 1) And brr(i, j) <= arr(d(brr(i, j + 1)), 2) Then _
    
14.                     crr(d(brr(i, j + 1)), 0) = crr(d(brr(i, j + 1)), 0) + brr(i, j + 2)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     [d2].Resize(d.Count) = crr
    
19. End Sub
    

复制代码

tangsong1026

        sql = "select sum(f3) from (select * from [Sheet1$A2:C" & Sheet1.[A65536].End(xlUp).Row & "]  union select * from [Sheet1$D:F" & Sheet1.[D65536].End(xlUp).Row & "]) where f1>=#" & .Cells(i, 1) & "# and f1<=#" & .Cells(i, 2) & "# and f2='" & .Cells(i, 3) & "'"
      
f1,f2,f3 这个用法不明白，而没有指定某一个单元格 很迷惑 大师能不能解释下？

mineshine

tangsong1026 发表于 2011-11-17 16:17
sql = "select sum(f3) from (select * from [Sheet1$A2:C" & Sheet1.[A65536].End(xlUp).Row & "] ...

conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName
在开启连结时，我指定了一个参数 : hdr=no
代表我不使用指定的栏位名，因为你的Sheet1栏位有"数据1","数据2"，
不使用栏位，则栏位就以f代表，第一栏就是f1,第二栏f2.....依此类推。

xyuer

mineshine 发表于 2011-11-17 15:47

代码看不懂啊，因为我还得学会运用到我的具体的工作的表格中，能不能给个解释，我才能学会运用的，谢了！

mineshine

xyuer 发表于 2011-11-17 22:32
代码看不懂啊，因为我还得学会运用到我的具体的工作的表格中，能不能给个解释，我才能学会运用的，谢了！

这是SQL语法


Sub Total()
Dim conn As Object, sql$, i As Long
Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName   '开启连结
With Sheets("Sheet2")
    .Range("D2:D65536").ClearContents   '清除Sheet2 D栏的小计
    For i = 2 To .[A65536].End(xlUp).Row   '从Sheet2 第2列往下到最后非空白列循环
     'sql语句: 将Sheet1 (A:C, D:F) 二份数据合併成一个只有三栏的数据库，依Sheet2设定的起迄日期和A,B,C类型加总数据
        sql = "select sum(f3) from (select * from [Sheet1$A2:C" & Sheet1.[A65536].End(xlUp).Row & "]  union select * from [Sheet1$D:F" & Sheet1.[D65536].End(xlUp).Row & "]) where f1>=#" & .Cells(i, 1) & "# and f1<=#" & .Cells(i, 2) & "# and f2='" & .Cells(i, 3) & "'"
         .Cells(i, 4).CopyFromRecordset conn.Execute(sql)    '将SQL得到的加总写入Sheet2 D栏单元格
    Next i
End With
conn.Close   '关闭连结
Set conn = Nothing
End Sub

xyuer

mineshine 发表于 2011-11-17 22:46
这是SQL语法

如何用VBA实现多条件求和2？.rar (13.04 KB, 下载次数: 706)

2011-11-17 23:31 上传

点击文件名下载附件
改版

由于原表格改版，麻烦高手再帮看看此文件，我已经为mineshine感激得彻夜难眠了！

mineshine

xyuer 发表于 2011-11-17 23:33
由于原表格改版，麻烦高手再帮看看此文件，我已经为mineshine感激得彻夜难眠了！

1. 
   
2. Sub Total()
   
3. Dim conn As Object, sql$, i As Long, j%, p$
   
4. Set conn = CreateObject("adodb.connection")    '建立连结
   
5. conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName   '开启连结
   
6. With Sheets("Sheet2")
   
7.      .Range("D:D,F:F,H:H").ClearContents   '清除Sheet2 D,E,F行
   
8.       p = "[Sheet1$A2:I" & Sheet1.[A65536].End(xlUp).Row & "]"  'SQL语句查询Sheet1工作表范围
   
9.       '合併Sheet1时间1~4,数据1~4成三行数据库
   
10.       sql = "select f1,f2,f6 from " & p & " where len(f2)>0 union select f1,f3,f7 from " & p & " Where len(f3)>0 union select f1,f4,f8 from " & p & " Where len(f4)>0 union select f1,f5,f9 from " & p & " Where len(f5)>0"
    
11.       Sheet1.Cells(1, 11).CopyFromRecordset conn.Execute(sql) '将SQL得到的合併数据写入Sheet1 K:M
    
12.      For i = 2 To .[A65536].End(xlUp).Row   '从Sheet2 第2列往下到最后非空白列循环
    
13.         For j = 3 To 7 Step 2
    
14.             '时间大于等于开始时间,小于等于结束时间, 且数据等于条件
    
15.             sql = "select sum(f3) from [Sheet1$K:M] where f2>=#" & .Cells(i, 1) & "# and f2<=#" & .Cells(i, 2) & "# and f1='" & .Cells(i, j) & "'"
    
16.             .Cells(i, j + 1).CopyFromRecordset conn.Execute(sql)  '将SQL得到的和计写加入Sheet2 D,F,H
    
17.         Next j
    
18.      Next i
    
19. End With
    
20. Sheet1.[K1:M65536].ClearContents  '清除Sheet1 K:M合併数据
    
21. conn.Close   '关闭连结
    
22. Set conn = Nothing
    
23. End Sub
    

复制代码

xyuer

mineshine 发表于 2011-11-18 08:20

真是万分感谢，我已经基本上实现了我想要的效果，可是在数据库中有一个小问题，如果sheet1中的姓名，时间和数据有两行或者更多行都完全一致的时候，在形成数据库时却只能形成一行数据，却删除了其他行，这是为何呢，急待解决！