|
|
强烈推荐：数组的地位。很多时候别人给你写再好的代码，但不能举一反三的，就等于什么也不会。
有10个工作簿，每个工作簿有100个工作表，每个工作表有10行数据。
=10*100*10=10000行。
非常有用，今天搞到这了，避免痔疮发作。
- '郑重声明：
- '所有代码由 zhaogang1960 版主版权所有，本人仅以附件数据为例修改测试。
- Sub 复制办法() '10.67秒
- Dim Mypath$, MyName$, sh As Worksheet, m&
- Cells.Clear
- tt = Timer
- Application.ScreenUpdating = False
- Mypath = ThisWorkbook.Path & ""
- MyName = Dir(Mypath & "*.xlsx")
- Do While MyName <> ""
- If MyName <> ThisWorkbook.Name Then
- Set wb = Workbooks.Open(Mypath & MyName)
- For Each sh In wb.Sheets
- m = m + 1
- If m < 1 Then '搞了半天，是小于1！！！！！！！！！！！！！！！！！！
- sh.Range("A4:O4").Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
- Else
- sh.Range("A5:O" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
- End If
- Next
- wb.Close False
- End If
- MyName = Dir
- Loop
- Application.ScreenUpdating = True
- MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
- End Sub
- Sub ADO加数组() '5秒
- Cells.ClearContents
- tt = Timer
- Dim cnn As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 20000, 0 To 14), i&, j&, m&
- Application.ScreenUpdating = False
- Mypath = ThisWorkbook.Path & ""
- MyName = Dir(Mypath & "*.xlsx")
- Do While MyName <> ""
- If InStr(MyName, ThisWorkbook.Name) = 0 Then
- Set cnn = CreateObject("ADODB.Connection")
- cnn.Open "Provider=Microsoft.ACE.Oledb.12.0;Extended Properties='Excel 12.0;hdr=NO';Data Source=" & Mypath & MyName
- Set rs = cnn.OpenSchema(20)
- Do Until rs.EOF
- If rs.Fields("TABLE_TYPE") = "TABLE" Then
- s = Replace(rs("TABLE_NAME").Value, "'", "")
- If Right(s, 1) = "$" Then
- SQL = "select * from [" & s & "A5:O] where F1 is not null"
- arr = cnn.Execute(SQL).GetRows
- For i = 0 To UBound(arr, 2)
- m = m + 1
- For j = 0 To 14
- brr(m, j) = arr(j, i)
- Next
- Next
- End If
- End If
- rs.MoveNext
- Loop
- End If
- MyName = Dir()
- Loop
- [A2].Resize(m, 15) = brr
- cnn.Close
- Set cnn = Nothing
- Application.ScreenUpdating = True
- MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
- End Sub
- Sub 纯数组() '虽然逐个打开工作簿，但只用了2.72秒。
- Cells.ClearContents
- tt = Timer
- Dim Mypath$, MyName$, arr, brr(1 To 20000, 1 To 15), i&, j&, m&, sh As Worksheet
- Mypath = ThisWorkbook.Path & ""
- MyName = Dir(Mypath & "*.xls")
- Application.ScreenUpdating = False
- Do While MyName <> ""
- If MyName <> ThisWorkbook.Name Then
- With Workbooks.Open(Mypath & MyName)
- For Each sh In .Sheets
- arr = sh.[A4].CurrentRegion
- For i = 2 To UBound(arr)
- If Len(arr(i, 1)) Then
- m = m + 1
- For j = 1 To 15
- brr(m, j) = arr(i, j)
- Next
- End If
- Next
- Next
- .Close False
- End With
- End If
- MyName = Dir
- Loop
- [A2].Resize(m, 15) = brr
- Application.ScreenUpdating = True
- MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
- End Sub
- Sub ADO联合查询() '9.92秒
- Dim cnn As Object, rs As Object, SQL$, Mypath$, MyFile$, m&, s$, r&
- Cells.ClearContents
- tt = Timer
- Application.ScreenUpdating = False
- Mypath = ThisWorkbook.Path & ""
- MyName = Dir(Mypath & "*.xlsx")
- Do While MyName <> ""
- If InStr(MyName, ThisWorkbook.Name) = 0 Then
- Set cnn = CreateObject("ADODB.Connection")
- cnn.Open "Provider=Microsoft.ACE.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyName
- Set rs = cnn.OpenSchema(20)
- Do Until rs.EOF
- If rs.Fields("TABLE_TYPE") = "TABLE" Then
- s = Replace(rs("TABLE_NAME").Value, "'", "")
- If Right(s, 1) = "$" Then
- m = m + 1
- If m > 49 Then
- Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
- m = 1
- SQL = ""
- End If
- If Len(SQL) Then SQL = SQL & " union all "
- SQL = SQL & "select * from [Excel 12.0;hdr=no;Database=" & Mypath & MyName & "].[" & s & "A5:O] where F1 is not null"
- End If
- End If
- rs.MoveNext
- Loop
- End If
- MyName = Dir()
- Loop
- If Len(SQL) Then Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
- rs.Close
- cnn.Close
- Set rs = Nothing
- Set cnn = Nothing
- Application.ScreenUpdating = True
- MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
- End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-11-10 22:38
楼主
