VBA：将多个工作簿的特定范围复制到一个工作表中

我有一个有很多（数百个）locking的.xls文件的文件夹。

我需要从每个文件中的一个工作表复制一个特定的范围到一个大的工作表，这将是我的数据文件，供将来分析。

我试图写一个macros，但不断收到错误。

请帮我debugging我写的东西：

 Sub ProcessFiles() ' declarations & definitions Dim Pathname As String Dim Filename As String Dim sourceWB As Workbook Dim targetWB As Workbook targetWB = ActiveWorkbook Pathname = ActiveWorkbook.Path & "\Files\" Filename = Dir(Pathname & "*.xls") ' loop through all files in folder Do While Filename <> "" Set sourceWB = Workbooks.Open(Pathname & Filename) ' unlock worksheets sourceWB.Sheets(4).Visible = True sourceWB.Sheets(4).Unprotect Password:="Password" sourceWB.Sheets(2).Unprotect Password:="Password" ' create new worksheet sourceWB.Sheets.Add After:=8 ' copy required cells to new sheets sourceWB.Sheets(2).Range("A14:FM663").Copy Destination:=sourceWB.Sheets(9).Range("C2") ' fill columns for all rows sourceWB.Sheets(9).Range("A2:A663").Value = sourceWB.Name sourceWB.Sheets(9).Range("B2:B663").Value = Worksheets(4).Range("C13").Value 'move AuxSheet to taget workbook sourceWB.Sheets(9).Move Before:=Workbooks(targetWB).Sheets(1) 'add to full data worksheet targetWB.Sheets(1).Range("A2:FO651").Copy Destination:=sourceWB.Sheets(2).Rows("3:" & Worksheets("Sheet2").UsedRange.Rows.Count) 'close file and repeat sourceWB.Close SaveChanges:=False Filename = Dir() Loop ' save result targetWB.Save End Sub 

Answer 1

只是想给你一个这样的任务如何处理更有效率的想法…考虑以下，我总是用这样的任务：

 Option Explicit ' 1. Add reference to Microsoft Scripting Runtime and Access Data Objects Library via Extras>References Sub ProcessFiles() Dim strCon As String Dim strSQL As String Dim fso As New Scripting.FileSystemObject Dim myfile As file With ThisWorkbook ' 2. empty your outputsheet .Sheets("out").Cells.Clear ' 3. loop the files in your folder For Each myfile In fso.GetFolder(.Path & Application.PathSeparator & "Files").Files ' 3.1. no proper way to filter files like in Dir(), but we want to use the file objects If myfile.Name Like "*.xls" Then ' 3.1.1. Construct the connection string, the only variable part is myfile.Path strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myfile.Path & ";Extended Properties='Excel 8.0;HDR=YES';" ' 3.1.2. Construct the SQL String. Luckily, you already know where your data is strSQL = "SELECT '" & myfile.Name & "' AS WorkbookName, * FROM [sheetData$A1:C5], (SELECT TOP 1 * FROM [sheetSchool$C12:C13])" ' 3.1.3. Call the get-data sub from below GetData .Sheets("out"), strCon, strSQL End If Next myfile End With End Sub Sub GetData(ByRef wsOut As Variant, strCon As String, strSQL As String) Dim i As Integer On Error GoTo skpError Application.ScreenUpdating = False ' Create a new database connection Dim objCon As New ADODB.Connection With objCon .ConnectionString = strCon .Open End With ' Create a new database command Dim objCmd As New ADODB.Command With objCmd .ActiveConnection = objCon .CommandType = adCmdText .CommandText = strSQL Debug.Print .CommandText End With ' Create a new recordset Dim objRS Set objRS = New ADODB.Recordset With objRS .ActiveConnection = objCon .Open objCmd End With ' Print your FieldNames, in case they're not already there With wsOut If wsOut.Cells(1, 1).Value = vbNullString Then For i = 1 To objRS.Fields.Count .Cells(1, i).Value = _ objRS.Fields(i - 1).Name Next i End If ' Output your data - pretty ugly, but reliable .Range("A1048576").End(xlUp).Offset(1, 0).CopyFromRecordset (objRS) End With skpNoError: Application.ScreenUpdating = True Exit Sub skpError: MsgBox "Error #" & Err & vbNewLine & Error, vbCritical GoTo skpNoError End Sub 

注意:(为什么使用这样的东西？）

• 受保护和隐藏的工作表不应该是这个问题。 对于受保护的工作簿，可以将密码参数添加到连接string中
• 这将大大快于大量的文件比打开，编辑，复制将是。 如果你觉得奇怪，可以通过将GetData Sub中的东西移动到ProcessFiles来进一步加快速度，所以它们不会被重复调用。
• 您使用数据库语言来查询数据，而不是一些笨拙的复制/粘贴机制。

编辑：编辑我的代码，对我来说，这与你给的例子。

• 从我收集的内容来看，您只能获得受保护的Worksheets ，而不是受密码保护的Workbook – 因此，无需取消隐藏或取消保护工作表
• 调整行strSQL = "SELECT '" & myfile.Name & "' AS WorkbookName, * FROM [sheetData$A1:C5], (SELECT TOP 1 * FROM [sheetSchool$C12:C13])"包含您的实际Sheets(2)和Sheets(4)名称