提取数据

zhaogang1960

请看附件:
提取.rar (132.76 KB, 下载次数: 15)

2013-7-19 18:54 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2013-7-19 18:54
请看附件:

当工作簿中有空白工作表时，这句会变成黄色的：
If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)

加了一句还是出错。
   If Application.WorksheetFunction.CountA(sht.UsedRange) Then

张雄友

zhaogang1960 发表于 2013-7-19 18:54
请看附件:

说对象关闭时不允许操作：

1.   Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, cat As Object, tb1 As Object, SH As Worksheet
   
3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         MyPath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Set cnn = CreateObject("ADODB.Connection")
    
11.     Set cat = CreateObject("ADOX.Catalog")
    
12.     Cells.ClearContents
    
13.     MyFile = Dir(MyPath & "*.xls")
    
14.     Do While MyFile <> ""
    
15.         If MyFile <> ThisWorkbook.Name Then
    
16.          For Each SH In Worksheets
    
17.         If Application.WorksheetFunction.CountA(SH.UsedRange) > 0 Then '忽略空工作表
    
18.             n = n + 1
    
19.             If n = 1 Then
    
20.                 cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
21.             Else
    
22.                 t = "[Excel 8.0;Database=" & MyPath & MyFile & "]."
    
23.             End If
    
24.             cat.ActiveConnection = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
25.             For Each tb1 In cat.Tables
    
26.                 If tb1.Type = "TABLE" Then
    
27.                     s = Replace(tb1.Name, "'", "")
    
28.                     If Right(s, 1) = "$" Then
    
29.                         If n = 1 Then
    
30.                             Set rs = cnn.Execute("[" & s & "]")
    
31.                             For i = 1 To rs.Fields.Count
    
32.                                 Cells(1, i) = rs.Fields(i - 1).Name
    
33.                             Next
    
34.                         End If
    
35.                         m = m + 1
    
36.                         If m > 49 Then
    
37.                             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
38.                             m = 1
    
39.                             SQL = ""
    
40.                         End If
    
41.                         If Len(SQL) Then SQL = SQL & " union all "
    
42.                         SQL = SQL & "select * from [" & s & "] where 代码='Q09'"
    
43.                     End If
    
44.                 End If
    
45.             Next
    
46.             End If
    
47.             Next
    
48.         End If
    
49.         MyFile = Dir()
    
50.     Loop
    
51.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
52.     cnn.Close
    
53.     Set cnn = Nothing
    
54.     Set cat = Nothing
    
55.     Set tb1 = Nothing
    
56.     Application.ScreenUpdating = True
    
57. End Sub
    

复制代码

zhaogang1960

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object
   
3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         MyPath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Set cnn = CreateObject("ADODB.Connection")
    
11.     Set cat = CreateObject("ADOX.Catalog")
    
12.     Cells.ClearContents
    
13.     MyFile = Dir(MyPath & "*.xls")
    
14.     On Error Resume Next
    
15.     Do While MyFile <> ""
    
16.         If MyFile <> ThisWorkbook.Name Then
    
17.             n = n + 1
    
18.             If n = 1 Then
    
19.                 cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
20.             Else
    
21.                 t = "[Excel 8.0;Database=" & MyPath & MyFile & "]."
    
22.             End If
    
23.             cat.ActiveConnection = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
24.             For Each tb1 In cat.Tables
    
25.                 If tb1.Type = "TABLE" Then
    
26.                     z = ""
    
27.                     z = tb1.Columns(0).Name
    
28.                     If Left$(z, 1) <> "F" Then
    
29.                         s = Replace(tb1.Name, "'", "")
    
30.                         If Right(s, 1) = "$" Then
    
31.                             v = v + 1
    
32.                             If v = 1 Then
    
33.                                 Set rs = cnn.Execute("[" & s & "]")
    
34.                                 For i = 1 To rs.Fields.Count
    
35.                                     Cells(1, i) = rs.Fields(i - 1).Name
    
36.                                 Next
    
37.                             End If
    
38.                             m = m + 1
    
39.                             If m > 49 Then
    
40.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
41.                                 m = 1
    
42.                                 SQL = ""
    
43.                             End If
    
44.                             If Len(SQL) Then SQL = SQL & " union all "
    
45.                             SQL = SQL & "select * from " & t & "[" & s & "] where 代码='Q09'"
    
46.                         End If
    
47.                     End If
    
48.                 End If
    
49.             Next
    
50.         End If
    
51.         MyFile = Dir()
    
52.     Loop
    
53.     On Error GoTo 0
    
54.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
55.     cnn.Close
    
56.     Set cnn = Nothing
    
57.     Set cat = Nothing
    
58.     Set tb1 = Nothing
    
59.     Application.ScreenUpdating = True
    
60. End Sub
    
61. 
    

复制代码

zhaogang1960

请看附件
提取.rar (135.54 KB, 下载次数: 10)

2013-7-19 21:42 上传

点击文件名下载附件

zhaogang1960

张雄友 发表于 2013-7-19 23:00
帮看看我改的怎么不对？
msg 对话框输入   代码
nsg 对话框输入   Q09

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object
   
3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         MyPath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Dim msg As String, nsg As String
   
10.     msg = Application.InputBox("请输入要查找的字段值" & vbCrLf & vbCrLf & "请注意大小写", Type:=2)
    
11.     nsg = Application.InputBox("请输入要查找的字段值的具体项目" & vbCrLf & vbCrLf & "请注意大小写", Type:=2)
    
12.    
    
13.     Application.ScreenUpdating = False
    
14.     Set cnn = CreateObject("ADODB.Connection")
    
15.     Set cat = CreateObject("ADOX.Catalog")
    
16.     Cells.ClearContents
    
17.     MyFile = Dir(MyPath & "*.xls")
    
18.     On Error Resume Next
    
19.     Do While MyFile <> ""
    
20.         If MyFile <> ThisWorkbook.Name Then
    
21.             n = n + 1
    
22.             If n = 1 Then
    
23.                 cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
24.             Else
    
25.                 t = "[Excel 8.0;Database=" & MyPath & MyFile & "]."
    
26.             End If
    
27.             cat.ActiveConnection = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
28.             For Each tb1 In cat.Tables
    
29.                 If tb1.Type = "TABLE" Then
    
30.                     z = ""
    
31.                     z = tb1.Columns(0).Name
    
32.                     If Left$(z, 1) <> "F" Then
    
33.                         s = Replace(tb1.Name, "'", "")
    
34.                         If Right(s, 1) = "$" Then
    
35.                             v = v + 1
    
36.                             If v = 1 Then
    
37.                                 Set rs = cnn.Execute("[" & s & "]")
    
38.                                 For i = 1 To rs.Fields.Count
    
39.                                     Cells(1, i) = rs.Fields(i - 1).Name
    
40.                                 Next
    
41.                             End If
    
42.                             m = m + 1
    
43.                             If m > 49 Then
    
44.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
45.                                 m = 1
    
46.                                 SQL = ""
    
47.                             End If
    
48.                             If Len(SQL) Then SQL = SQL & " union all "
    
49.                             SQL = SQL & "select * from " & t & "[" & s & "] where " & msg & " like '" & nsg & "%'"
    
50.                         End If
    
51.                     End If
    
52.                 End If
    
53.             Next
    
54.         End If
    
55.         MyFile = Dir()
    
56.     Loop
    
57.     On Error GoTo 0
    
58.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
59.     cnn.Close
    
60.     Set cnn = Nothing
    
61.     Set cat = Nothing
    
62.     Set tb1 = Nothing
    
63.     Application.ScreenUpdating = True
    
64. End Sub
    
65. 
    

复制代码

zhaogang1960

请看附件
提取新问题.rar (138.97 KB, 下载次数: 19)

2013-7-19 23:07 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2013-7-19 21:43
请看附件

帮看看我改的怎么不对？
msg 对话框输入   代码
nsg 对话框输入   Q09

会出错的？说：11$不是一个有效的名称,什么原因?

张雄友

zhaogang1960 发表于 2013-7-19 23:08
请看附件

加多一个%,是模糊匹配的原因吗?

zhaogang1960

张雄友 发表于 2013-7-19 23:13
加多一个%,是模糊匹配的原因吗?

SQL = SQL & "select * from " & t & "[" & s & "] where " & msg & " like '" & nsg & "%'"