求VBA跨表检索重复次数与对应项求和

feilv205

lsdongjh 发表于 2018-9-7 09:06

非常感谢老师！

代码执行到34或37时出错，我把补充后的表上传，代码已在表上，麻烦老师帮看下，谢谢！

lsdongjh

仔细看一下你的BX01和SQL语句，字段名要和第一行的标题对应！如果有空行，需要，加一个条件
    strSQL = "SELECT  产品编号, Count(产品编号) AS 次数, Sum(数量) AS 到料总数  FROM [BX1$] WHERE 产品编号 <>'' GROUP BY 产品编号;"

lsdongjh

1. Sub BOB() 'SQL法
   
2.     Dim shResult As Worksheet
   
3.     Dim arrResult As Variant, arrSource As Variant, lngRow As Long, lngRowID As Long
   
4.     Dim objDic As Object, strKey As String
   
5.     Dim Conn As Object, Rst As Object, strPath As String
   
6.     Dim strConn As String, strSQL As String
   
7. 
   
8.     Set shResult = Sheets("B1")
   
9.     lngRow = shResult.Range("B" & Rows.Count).End(xlUp).Row
   
10.     arrResult = shResult.Range("B1:L" & lngRow)
    
11.    
    
12.     Set objDic = CreateObject("Scripting.Dictionary")
    
13.     For lngRow = 2 To UBound(arrResult)
    
14.         strKey = arrResult(lngRow, 1)
    
15.         If strKey <> "" Then objDic(strKey) = lngRow
    
16.     Next
    
17.    
    
18.     Set Conn = CreateObject("ADODB.Connection")
    
19.     Set Rst = CreateObject("ADODB.Recordset")
    
20.     strPath = "F:\Temp\666\BX01.xlsx" '这是BX01所在的路径及文件名！
    
21.     Select Case Application.Version * 1
    
22.         Case Is <= 11
    
23.             strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
    
24.         Case Is >= 12
    
25.             strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
26.     End Select
    
27.     Conn.Open strConn
    
28.     strSQL = "SELECT  产品编号, Count(产品编号) AS 次数, Sum(数量) AS 到料总数, Sum([投产累计数]) AS 生产累计,Sum([X1累计废品1]) AS 废品1累计, Sum([X1累计废品2]) AS 废品2累计,Sum([X1累计废品3]) AS 废品3累计, Sum([X1累计成品数量]) AS 成品数1累计  FROM [BX1$]  WHERE 产品编号 <>''  GROUP BY 产品编号;"
    
29.     Rst.Open strSQL, Conn, 3, 1
    
30.     arrSource = Rst.getrows
    
31.    
    
32.     Rst.Close: Set Rst = Nothing
    
33.     Conn.Close: Set Conn = Nothing
    
34.    
    
35.     For lngRow = LBound(arrSource, 2) To UBound(arrSource, 2)
    
36.         strKey = arrSource(0, lngRow)
    
37.         If objDic.Exists(strKey) Then
    
38.             lngRowID = objDic(strKey)
    
39.             arrResult(lngRowID, 5) = arrSource(1, lngRow)
    
40.             arrResult(lngRowID, 6) = arrSource(2, lngRow)
    
41.             arrResult(lngRowID, 7) = arrSource(3, lngRow)
    
42.             arrResult(lngRowID, 8) = arrSource(4, lngRow)
    
43.             arrResult(lngRowID, 9) = arrSource(5, lngRow)
    
44.             arrResult(lngRowID, 10) = arrSource(6, lngRow)
    
45.             arrResult(lngRowID, 11) = arrSource(7, lngRow)
    
46.         End If
    
47.     Next
    
48.    
    
49.     shResult.Range("B1").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
    
50.    
    
51.     MsgBox "OK!"
    
52. End Sub

复制代码

feilv205

lsdongjh 发表于 2018-9-7 10:34

圆满解决问题！

真心感谢老师！