提取数据

张雄友

zhaogang1960 发表于 2013-7-18 23:18
复制一个表头:

要查询日期时，将SQL = SQL & "select * from [" & sh.Name & "$] where 代码='Q09'"

改成；SQL = SQL & "select * from [" & sh.Name & "$] where 日期= 2013-5-28"

怎么会出错？

zhaogang1960

张雄友 发表于 2013-7-18 23:33
要查询日期时，将SQL = SQL & "select * from [" & sh.Name & "$] where 代码='Q09'"

改成；SQL = SQL ...

如果条件是文本，则用单引号括起来
如果条件是日期，则用单#号括起来

清风幽闲

Sub 提取数据()
Sheets(1).Select
lastrow = Cells(Rows.Count, "l").End(3).Row
arr1 = Range("a2:o" & lastrow)
Sheets(2).Select
lastrow = Cells(Rows.Count, "l").End(3).Row
arr2 = Range("a2:o" & lastrow)
Sheets(3).Select
Sheets(1).Rows(1).Copy
Range("a1").PasteSpecial
For Each myarr In Array(arr1, arr2)
    For n = 1 To UBound(myarr)
        If myarr(n, 12) = "Q09" Then
            i = i + 1
            For j = 1 To UBound(myarr, 2)
                Cells(i + 1, j) = myarr(n, j)
            Next j
        End If        
    Next n
Next myarr
End Sub

清风幽闲

多表提取数据.rar (46.21 KB, 下载次数: 19)

2013-7-19 09:59 上传

点击文件名下载附件

清风幽闲

Sub 提取数据()
For Each wsh In Sheets
    If wsh.Name <> "提取数据" Then
        wsh.Select
        lastrow = Cells(Rows.Count, 12).End(3).Row
        arr = Range("a2:o" & lastrow)
        Sheets("提取数据").Select
        For n = 1 To UBound(arr)
            If arr(n, 12) = "Q09" Then
                i = i + 1
                For j = 1 To UBound(arr, 2)
                    Cells(i + 1, j) = arr(n, j)
                Next j
            End If
        Next n
        Erase arr
    End If
Next wsh
Sheets(1).Rows(1).Copy
Range("a1").PasteSpecial
End Sub
这样代码可能更简便些

张雄友

zhaogang1960 发表于 2013-7-18 23:59
如果条件是文本，则用单引号括起来
如果条件是日期，则用单#号括起来

版主，如果不只是提取单个工作簿，而是提取某个文件夹内的所有工作簿的数据呢？

zhaogang1960

张雄友 发表于 2013-7-19 18:13
版主，如果不只是提取单个工作簿，而是提取某个文件夹内的所有工作簿的数据呢？

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

复制代码

zhaogang1960

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

2013-7-19 18:45 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2013-7-19 18:43

打开文件夹能用 FileDialog(msoFileDialogFolderPicker) 对话框形式吗？

zhaogang1960

张雄友 发表于 2013-7-19 18:50
打开文件夹能用 FileDialog(msoFileDialogFolderPicker) 对话框形式吗？

1. 
   
2. 
   
3. Sub Macro1()
   
4.     Dim cnn As Object, rs As Object, cat As Object, tb1 As Object
   
5.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .InitialFileName = ThisWorkbook.Path & ""
   
8.         If .Show = False Then Exit Sub
   
9.         MyPath = .SelectedItems(1) & ""
   
10.     End With
    
11.     Application.ScreenUpdating = False
    
12.     Set cnn = CreateObject("ADODB.Connection")
    
13.     Set cat = CreateObject("ADOX.Catalog")
    
14.     Cells.ClearContents
    
15.     MyFile = Dir(MyPath & "*.xls")
    
16.     Do While MyFile <> ""
    
17.         If MyFile <> ThisWorkbook.Name 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.         MyFile = Dir()
    
48.     Loop
    
49.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
50.     cnn.Close
    
51.     Set cnn = Nothing
    
52.     Set cat = Nothing
    
53.     Set tb1 = Nothing
    
54.     Application.ScreenUpdating = True
    
55. End Sub
    
56. 
    

复制代码