VBA跨工作薄按条件取数

zhaogang1960

ZCJ521 发表于 2012-7-21 17:29
本想把代码移植到这个表格中来，水平有限，老是出问题，愁死我了。

没有看懂，请说明一下具体要求

ZCJ521

zhaogang1960 发表于 2012-7-21 17:44
没有看懂，请说明一下具体要求

从数据明细表中抽取符合条件的数据(明细表中C列到N列的数据)到信息总表，条件就是根据选定的信息总表中的H列数据，和E列的数据来判断选取！跟刚才那个表类似，就是格式有点不一样！

zhaogang1960

ZCJ521 发表于 2012-7-21 17:51
从数据明细表中抽取符合条件的数据(明细表中C列到N列的数据)到信息总表，条件就是根据选定的信息总表中的 ...

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, s$, t$, arr, i&, rng As Range, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set rng = Selection
   
5.     If rng.Columns.Count = 1 And Not Intersect(rng, [h4:h60000]) Is Nothing Then
   
6.         arr = rng.Offset(, -3).Resize(, 4)
   
7.         For i = 1 To UBound(arr)
   
8.             If Len(arr(i, 1)) Then d(arr(i, 1)) = ""
   
9.         Next
   
10.         k = d.keys
    
11.         If d.Count > 0 Then
    
12.             For i = 0 To d.Count - 1
    
13.                 If SQL1 <> "" Then SQL1 = SQL1 & " union all "
    
14.                 SQL1 = SQL1 & "select * from [" & k(i) & "$b4:n]"
    
15.             Next
    
16.             Set cnn = CreateObject("ADODB.Connection")
    
17.             cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.Path & "\数据明细表.xlsx"
    
18.             If rng.Rows.Count = 1 Then t = rng.Address(0, 0) & ":" & rng.Address(0, 0) Else t = rng.Address(0, 0)
    
19.             s = "select f1 from [Excel 12.0;hdr=no;Database=" & ThisWorkbook.FullName & "].[信息总表$" & t & "]"
    
20.             SQL = "select b.f2,b.f3,b.f4,b.f5,b.f6,b.f7,b.f8,b.f9,b.f10,b.f11,b.f12,b.f13 from (" & s & ") a left join (" & SQL1 & ") b on a.f1=b.f1"
    
21.             rng.Offset(, 1).Cells(1).CopyFromRecordset cnn.Execute(SQL)
    
22.             cnn.Close
    
23.             Set cnn = Nothing
    
24.         Else
    
25.             MsgBox "请选择化验批号"
    
26.         End If
    
27.     End If
    
28. End Sub
    

复制代码

zhaogang1960

请看附件
测试.rar (167.04 KB, 下载次数: 42)

2012-7-21 18:05 上传

点击文件名下载附件

ZCJ521

zhaogang1960 发表于 2012-7-21 17:58

为什么跳着选单元格会出错，比如按着CTRL键选H3和H6单元格，点取数，就出错了

zhaogang1960

ZCJ521 发表于 2012-7-21 18:16
为什么跳着选单元格会出错，比如按着CTRL键选H3和H6单元格，点取数，就出错了

为了加快速度，这个程序不支持“跳着选单元格”

还有附件中不同工作表中，“包装批次”有重复，如果实际上是这样，程序需要修改

ZCJ521

zhaogang1960 发表于 2012-7-21 18:23
为了加快速度，这个程序不支持“跳着选单元格”

还有附件中不同工作表中，“包装批次”有重复，如果实 ...

同一个工作表中，包装批次不会有重复的。但二个工作表的包装批次，特殊情况下就有可能有重复的，所以在信息总表的前面E列也是一个条件，相当于指定了取数的工作表.

zhaogang1960

ZCJ521 发表于 2012-7-21 18:29
同一个工作表中，包装批次不会有重复的。但二个工作表的包装批次，特殊情况下就有可能有重复的，所以在信 ...

哦，要对付的就是不同的工作表中可能会有相同的包装批次，修改如下

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, s$, temp$, arr, i&, rng As Range, d As Object, k, t
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set rng = Selection
   
5.     If rng.Columns.Count = 1 And Not Intersect(rng, [h4:h60000]) Is Nothing Then
   
6.         arr = rng.Offset(, -3).Resize(, 4)
   
7.         For i = 1 To UBound(arr)
   
8.             If Len(arr(i, 1)) Then
   
9.                 If Not d.Exists(arr(i, 1)) Then d(arr(i, 1)) = "'" & arr(i, 4) & "'" Else d(arr(i, 1)) = d(arr(i, 1)) & ",'" & arr(i, 4) & "'"
   
10.             End If
    
11.         Next
    
12.         k = d.keys
    
13.         t = d.items
    
14.         If d.Count > 0 Then
    
15.             For i = 0 To d.Count - 1
    
16.                 If SQL1 <> "" Then SQL1 = SQL1 & " union all "
    
17.                 SQL1 = SQL1 & "select * from [" & k(i) & "$b4:n] where f1 in (" & t(i) & ")"
    
18.             Next
    
19.             Set cnn = CreateObject("ADODB.Connection")
    
20.             cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.Path & "\数据明细表.xlsx"
    
21.             If rng.Rows.Count = 1 Then temp = rng.Address(0, 0) & ":" & rng.Address(0, 0) Else temp = rng.Address(0, 0)
    
22.             s = "select f1 from [Excel 12.0;hdr=no;Database=" & ThisWorkbook.FullName & "].[信息总表$" & temp & "]"
    
23.             SQL = "select b.f2,b.f3,b.f4,b.f5,b.f6,b.f7,b.f8,b.f9,b.f10,b.f11,b.f12,b.f13 from (" & s & ") a left join (" & SQL1 & ") b on a.f1=b.f1"
    
24.             rng.Offset(, 1).Cells(1).CopyFromRecordset cnn.Execute(SQL)
    
25.             cnn.Close
    
26.             Set cnn = Nothing
    
27.         Else
    
28.             MsgBox "请选择化验批号"
    
29.         End If
    
30.     End If
    
31. End Sub
    

复制代码

zhaogang1960

请看附件
测试.rar (169.15 KB, 下载次数: 55)

2012-7-21 18:35 上传

点击文件名下载附件

ZCJ521

zhaogang1960 发表于 2012-7-21 18:35
请看附件

经过初步测式，好像没什么大的问题了，太牛了！唯一的小问题就是还不能选用CTRL键进行多单元格选择取数，选择相邻的二个单元格，如果按了CTRL键选，也会报错！