跨工作簿查找对应专卖店的刷卡金额

wyjgni

本人VBA知识浅薄，如何跨工作簿查找，请高手指教。有附件上传。

LMY123

同夹多薄多表查找及汇总

wyjgni

朱荣兴 发表于 2018-8-16 10:07
关键是你要说明白要如何查找？？:

我就是想知道如何查找，把每个月专卖店对应的刷卡金额放在一个表格里

wyjgni

碧眼专卖店每月刷卡金额分布在12个月，如何各月刷卡金额按照专卖店按照月份，按照鞋类和皮具查找在一张表格里

wyjgni

LMY123 发表于 2018-8-16 11:39
同夹多薄多表查找及汇总

把1月2月3月刷卡分别对应专卖店进行查找

wyjgni

LMY123 发表于 2018-8-16 11:39
同夹多薄多表查找及汇总

把1月2月3月刷卡分别对应专卖店的类别进行查找

LMY123

wyjgni 发表于 2018-8-16 12:29
把1月2月3月刷卡分别对应专卖店的类别进行查找

1. 'http://club.excelhome.net/thread-1195938-1-1.html
   
2. Sub ADO加字典法_鞋()
   
3.     CRR = ActiveSheet.Range("A1:C61")
   
4.     Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, s$, t$
   
5.     Dim arr, brr(1 To 65530, 0 To 2), d As Object, i&, j&, m&
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     MyPath = ThisWorkbook.Path & ""
   
8.     MyFile = Dir(MyPath & "*.xls")
   
9.     Do While MyFile <> ""
   
10.         If InStr(MyFile, ThisWorkbook.Name) = 0 Then
    
11.             Set cnn = CreateObject("ADODB.Connection")
    
12.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
13.             Set rs = cnn.OpenSchema(20)
    
14.             Do Until rs.EOF
    
15.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
16.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
17.                     If Right(s, 1) = "$" Then
    
18.                         If InStr(s, "专卖") Then
    
19.                             SQL = "select * from [" & s & "A2:U] where 专卖店名 is not null and 专卖店名<>'合计'"
    
20.                             arr = cnn.Execute(SQL).GetRows
    
21.                             For i = 0 To UBound(arr, 2)
    
22.                                 t = arr(0, i)
    
23.                                 If Not d.Exists(t) Then
    
24.                                     m = m + 1
    
25.                                     d(t) = m
    
26.                                     For j = 0 To 0
    
27.                                         brr(m, j) = arr(j, i)
    
28.                                         brr(m, 1) = "鞋"
    
29.                                     Next
    
30.                                 Else
    
31.                                     brr(d(t), 2) = brr(d(t), 2) + arr(12, i)
    
32.                                 End If
    
33.                             Next
    
34.                         End If
    
35.                     End If
    
36.                 End If
    
37.                 rs.MoveNext
    
38.             Loop
    
39.         End If
    
40.         MyFile = Dir()
    
41.     Loop
    
42.     ActiveSheet.UsedRange.Offset(1, 2).ClearContents
    
43.     ReDim drr(1 To UBound(CRR), 1 To 1)
    
44.     For X = 2 To 44
    
45.         For Y = 1 To m
    
46.             If InStr(CRR(X, 1), brr(Y, 0)) Then
    
47.                 K = K + 1
    
48.                 drr(K, 1) = brr(Y, 2)
    
49.             End If
    
50.         Next Y
    
51.     Next X
    
52.     [C2].Resize(UBound(CRR), 1) = drr
    
53.     rs.Close
    
54.     cnn.Close
    
55.     Set rs = Nothing
    
56.     Set cnn = Nothing
    
57. End Sub

复制代码