|
Sub 多工作簿多工作表提取数据() '每个工作簿都有多个格式相同的工作表”
tt = Timer
Dim cnn As Object
Dim SQL$, MyPath$, MyFile$, wk$, a, i%, t$, m%, n%
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Offset(1).ClearContents
MyPath = ThisWorkbook.Path & "\"
MyFile = Dir(MyPath & "*.xlsx")
Set cnn = CreateObject("adodb.connection")
Do While MyFile <> ""
If MyFile <> ThisWorkbook.Name Then
n = n + 1
If n = 1 Then cnn.Open "Provider = Microsoft.ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & MyPath & MyFile
Set rs = cnn.OpenSchema(20)
wk = Replace(Replace(MyFile, ".xlsx", ""), "数据", "")
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(s, 1) = "$" Then
cname = Replace(s, "$", "")
SQL = "select '" & wk & "' , '" & cname & "',* from [" & s & "a1:k] where instr(科目名称,'小计')=0 order by 1,2,3"
lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("a" & lr).CopyFromRecordset cnn.Execute(SQL)
End If
End If
rs.MoveNext
Loop
End If
MyFile = Dir()
Loop
If Len(SQL) Then [a1024768].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox Timer - tt
End Sub
|
|