여러 통합 문서를 하나의 통합 문서로 통합 문서로 통합

Question

각 통합 문서에는 하나의 워크 시트가있는 65 개의 통합 문서가 있습니다. 모든 65 개의 통합 문서를 하나의 통합 문서로 결합해야하며 모든 통합 문서는 새로운 통합 문서의 65 개의 워크 시트로 통합해야합니다. 새 통합 문서의 워크 시트 이름으로 65 개의 통합 문서 이름을 모두 유지해야합니다.

이 작업을 수행하기 위해 지금까지 온라인에서 찾은 코드가 있지만이 코드는 병합 될 모든 통합 문서가 열려 있어야합니다. 모든 통합 문서를 열 필요가 없도록이 코드를 수정할 방법이 있습니까? 드라이브의 위치를 ​​참조 (폴더) 할 수 있습니까?

도움 주셔서 감사합니다. 여기

코드입니다 :

이

Option Explicit 
Public u_sheets As String 

Sub Consolidate() 

Dim ws As Worksheet 
Dim wb As Workbook, NewBook As Workbook 
Dim scount As Integer 
Dim NewWS As Worksheet 
Dim wsSheet As Worksheet 
Dim i As Integer 
Dim NextName As String 
Dim sl As Integer 
Dim newfilepath As String 
    newfilepath = "" 
Dim first_only As Boolean 
    first_only = False 

Call init 

'are we doing the first sheet only? 
If u_sheets = "First Sheet Only" Then first_only = True  

'Setup 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.DisplayAlerts = False 

'Create new workbook for merged sheets 
newfilepath = ThisWorkbook.Path & "\Merged" 'excel will auto append the appropriate extension (xlsx) 
Set NewBook = Workbooks.Add 
NewBook.SaveAs Filename:=newfilepath 

i = 1 

'Loop through each open workbook 
For Each wb In Workbooks 

    If wb.Name <> ThisWorkbook.Name And wb.Name <> NewBook.Name And Left(wb.Name, 8) <> "PERSONAL" Then 

    Dim x As String 

    'Get name of this workbook 
    x = JustText(Left(wb.Name, Len(wb.Name) - 4)) 

     'count sheets in this workbook 
     If first_only Then 
      scount = 1 
     Else 
      scount = wb.Sheets.Count 
     End If   
     'Loop through each sheet in Workbook 
     For Each ws In wb.Worksheets 
      'do some naming conventions 
      Dim xy As String 
      Dim y As String 
      y = JustText(ws.Name) 'strip out all characters from name 
      If scount > 1 Then     
       xy = x + y     
      Else     
       xy = x     
      End If 

      'check the length of the new name and shorten if needed 
      sl = Len(xy) 

      If sl > 30 Then     
       xy = Right(x, sl - (sl - 30))     
      End If 

      'copy worksheet to new workbook 
      ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count) 

      'rename worksheet 
      NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy 
      If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet 

     Next  
    End If  
Next 

'remove all original worksheets 
'NewBook.Worksheets("Sheet1").Delete 
'NewBook.Worksheets("Sheet2").Delete 
'NewBook.Worksheets("Sheet3").Delete  

ErrorExit: 'Cleanup 
    Application.DisplayAlerts = True 'turn system alerts back on 
    Application.EnableEvents = True  'turn other macros back on 
    Application.ScreenUpdating = True 'refreshes the screen 

End Sub 

Private Function JustText(text_to_clean As String, Optional upper As Boolean = False) 
    'removes all characters except for letters and numbers 
    'where 
    'text_to_clean is the text to clean 
    'upper boolean will return UPPER case if true; false if omitted 

    'declare and initialize user variables 

    Dim method As Integer 
     'choices: 
     '1=remove everything except what is in the leave_these variable 
     '2=leave everything except what is specifically removed from the "leave" section 
     method = 1 

    Dim leave_these As String 'only used if method=1 
     leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 " 

    'declare and initialize system variables 
    Dim temp As String 
     temp = text_to_clean 

    'method 
    Select Case method 
     Case 1 'remove everything except what is in the leave_these variable 
      Dim x As String, y As String, z As String, i As Long 
      x = temp 
       For i = 1 To Len(x) 
        y = Mid(x, i, 1) 
        If y Like "[" & leave_these & "]" Then z = z & y 
       Next i 
      temp = z 

     Case 2 'leave everything except characters below 
      'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired 
      temp = Replace(temp, ",", "") 'remove commas 
      temp = Replace(temp, " ", "") 'remove spaces 
      temp = Replace(temp, "-", "") 'remove dashes 
      temp = Replace(temp, ":", "") 'remove colon 
      temp = Replace(temp, ";", "") 'remove semi-colon    
    End Select  

    If upper Then JustText = UCase(temp) Else JustText = temp  
End Function 

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean 

On Error Resume Next 
WorksheetExists = (Sheets(WorksheetName).Name <> "") 
On Error GoTo 0  
End Function 

Private Sub init() 
    'initialize all public variables 
    u_sheets = Range("u_sheets")  
End Sub 

Answer 1

예, 당신은 사용 후 그래서 그 디렉토리에 .XLS 또는 .XLSX 또는 XLSM (귀하의 경우에 맞는 무엇이든) 존재하는 참조 Dir 명령을 사용할 수있는 루프를 사용하여 Workbooks.Open을 열어 원래 통합 문서에 시트를 추가하고 닫은 다음 Dir 목록의 다음 통합 문서로 반복하십시오. 이런 식으로 예를 들어

를 사용하여 디렉터리 :

Dim strPath As String 
    Dim strFile As String 

    strPath = "C:\yourfolder\" 

    strFile = Dir(strPath & "*.xlsx") 

    Do Until strFile = "" 

     ' ...YOURCODE HERE 

    Loop 

이것은 For each wb in Workbooks의 자리에 올 것입니다, 당신은 Set wb = Workbooks.Open strPath & strFile을 적용하고 여전히 시트를 복사 할 원본 코드의 나머지 부분의 사용을 만들 수 있습니다.

Answer 2

가급적이면 addin RDBMerge를 사용하십시오.

RDBMerge는

http://www.rondebruin.nl/merge.htm

Merge Multiple Workbooks From Different Folders Into One

Answer 3

이 코드 (이전에 다른 포럼에서 호스팅)가 제공하는 요약 통합 문서에 여러 엑셀 통합 문서, CSV 및 XML 파일에서 데이터를 병합 할 수있는 사용자 친화적 인 방법입니다 세 가지 옵션 :

1. 하나의 폴더에있는 모든 Excel 통합 문서의 모든 시트를 단일 요약 w orksheet
2. 한 부씩 인쇄 하나의 요약 통합 문서
3. 한 부씩 인쇄에 하나의 폴더에있는 모든 Excel 통합 문서의 모든 시트를 단일 요약 워크 시트에 단일 Excel 통합 문서의 모든 시트

요청입니다 (2).

코드

Public Sub ConsolidateSheets() 
    Dim Wb1 As Workbook 
    Dim Wb2 As Workbook 
    Dim ws1 As Worksheet 
    Dim ws2 As Worksheet 
    Dim ws3 As Worksheet 
    Dim rng1 As Range 
    Dim rng2 As Range 
    Dim rng3 As Range 
    Dim rngArea As Range 
    Dim lrowSpace As Long 
    Dim lSht As Long 
    Dim lngCalc As Long 
    Dim lngRow As Long 
    Dim lngCol As Long 
    Dim X() 
    Dim bProcessFolder As Boolean 
    Dim bNewSheet As Boolean 

    Dim StrPrefix 
    Dim strFileName As String 
    Dim strFolderName As String 

    'variant declaration needed for the Shell object to use a default directory 
    Dim strDefaultFolder As Variant 


bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes) 
    bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes) 
    If Not bProcessFolder Then 
     If Not bNewSheet Then 
      MsgBox "There isn't much point creating a exact replica of your source file :)" 
      Exit Sub 
     End If 
    End If 

    'set default directory here if needed 
    strDefaultFolder = "C:\temp" 

    'If the user is collating all the sheets to a single target sheet then the row spacing 
    'to distinguish between different sheets can be set here 
    lrowSpace = 1 

    If bProcessFolder Then 
     strFolderName = BrowseForFolder(strDefaultFolder) 
     'Look for xls, xlsx, xlsm files 
     strFileName = Dir(strFolderName & "\*.xls*") 
    Else 
     strFileName = Application _ 
         .GetOpenFilename("Select file to process (*.xls*), *.xls*") 
    End If 

    Set Wb1 = Workbooks.Add(1) 
    Set ws1 = Wb1.Sheets(1) 
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count") 

    'Turn off screenupdating, events, alerts and set calculation to manual 
    With Application 
     .DisplayAlerts = False 
     .EnableEvents = False 
     .ScreenUpdating = False 
     lngCalc = .Calculation 
     .Calculation = xlCalculationManual 
    End With 

    'set path outside the loop 
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString) 

    Do While Len(strFileName) > 0 
     'Provide progress status to user 
     Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255) 
     'Open each workbook in the folder of interest 
     Set Wb2 = Workbooks.Open(StrPrefix & strFileName) 
     If Not bNewSheet Then 
      'add summary details to first sheet 
      ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name 
      ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count 
     End If 
     For Each ws2 In Wb2.Sheets 
      If bNewSheet Then 
       'All data to a single sheet 
       'Skip importing target sheet data if the source sheet is blank 
       Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious) 

       If Not rng2 Is Nothing Then 
        Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious) 
        'Find the first blank row on the target sheet 
        If Not rng1 Is Nothing Then 
         Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A")) 
         'Ensure that the row area in the target sheet won't be exceeded 
         If rng3.Rows.Count + rng1.Row < Rows.Count Then 
          'Copy the data from the used range of each source sheet to the first blank row 
          'of the target sheet, using the starting column address from the source sheet being copied 
          ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column) 
         Else 
          MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _ 
            "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name 
          Wb2.Close False 
          Exit Do 
         End If 
         'colour the first of any spacer rows 
         If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen 
        Else 
         'target sheet is empty so copy to first row 
         ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column) 
        End If 
       End If 
      Else 
       'new target sheet for each source sheet 
       ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count) 
       'Remove any links in our target sheet 
       With Wb1.Sheets(Wb1.Sheets.Count).Cells 
        .Copy 
        .PasteSpecial xlPasteValues 
       End With 
       On Error Resume Next 
       Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name 
       'sheet name already exists in target workbook 
       If Err.Number <> 0 Then 
        'Add a number to the sheet name till a unique name is derived 
        Do 
         lSht = lSht + 1 
         Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht) 
        Loop While Not ws3 Is Nothing 
        lSht = 0 
       End If 
       On Error GoTo 0 
      End If 
     Next ws2 
     'Close the opened workbook 
     Wb2.Close False 
     'Check whether to force a DO loop exit if processing a single file 
     If bProcessFolder = False Then Exit Do 
     strFileName = Dir 
    Loop 

    'Remove any links if the user has used a target sheet 
    If bNewSheet Then 
     With ws1.UsedRange 
      .Copy 
      .Cells(1).PasteSpecial xlPasteValues 
      .Cells(1).Activate 
     End With 
    Else 
     'Format the summary sheet if the user has created separate target sheets 
     ws1.Activate 
     ws1.Range("A1:B1").Font.Bold = True 
     ws1.Columns.AutoFit 
    End If 

    With Application 
     .CutCopyMode = False 
     .DisplayAlerts = True 
     .EnableEvents = True 
     .ScreenUpdating = True 
     .Calculation = lngCalc 
     .StatusBar = vbNullString 
    End With 
End Sub 


Function BrowseForFolder(Optional OpenAt As Variant) As Variant 
'From Ken Puls as used in his vbaexpress.com article 
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284 

    Dim ShellApp As Object 
    'Create a file browser window at the default folder 
    Set ShellApp = CreateObject("Shell.Application"). _ 
        BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 

    'Set the folder to that selected. (On error in case cancelled) 
    On Error Resume Next 
    BrowseForFolder = ShellApp.self.Path 
    On Error GoTo 0 

    'Destroy the Shell Application 
    Set ShellApp = Nothing 

    'Check for invalid or non-entries and send to the Invalid error 
    'handler if found 
    'Valid selections can begin L: (where L is a letter) or 
    '\\ (as in \\servername\sharename. All others are invalid 
    Select Case Mid(BrowseForFolder, 2, 1) 
    Case Is = ":" 
     If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 
    Case Is = "\" 
     If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 
    Case Else 
     GoTo Invalid 
    End Select 

    Exit Function 

Invalid: 
    'If it was determined that the selection was invalid, set to False 
    BrowseForFolder = False 
End Function