VBA : 여러 통합 문서의 특정 범위를 하나의 워크 시트로 복사

Question

로크 번호가 여러 개인 폴더가 있습니다 (.xls).

각 파일의 워크 시트 중 하나에서 특정 범위를 큰 워크 시트로 복사해야합니다.이 워크 시트는 향후 분석을위한 데이터 파일입니다.

매크로를 작성하려고했지만 오류가 계속 발생했습니다. ...의 I는 항상이 같은 작업에 사용하는 다음 사항을 고려

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 - 그러므로 실제 Sheets(2) 및 Sheets(4) 이름
를 포함 할
• 이 라인 strSQL = "SELECT '" & myfile.Name & "' AS WorkbookName, * FROM [sheetData$A1:C5], (SELECT TOP 1 * FROM [sheetSchool$C12:C13])"을 조정
워크 시트 숨기기를 취소하거나 보호를 해제 할 필요가 없습니다