Question

我有一个包含大量（数百个）锁定.xls文件的文件夹。

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

我试图为此编写一个宏，但不断收到错误。

请帮我调试我写的内容：

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

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

受保护和隐藏的工作表不应该是这个问题。对于受保护的工作簿，可以将密码参数添加到连接字符串
对于大量文件来说，这比打开，编辑，复制要快得多。如果您觉得有点兴趣，可以通过将内容从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)名称

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

1 个答案: