워크 시트를 하나의 엑셀 워크 북으로 가져 오기

Question

나는 111 개의 엑셀 워크 북이있는 폴더가 있습니다. 모든 파일을 하나의 Excel 파일에 복사하여 다른 시트에 붙여 넣기를 원합니다. 따라서 한 장의 시트에는 한 파일의 내용이 있어야합니다. 각 파일에는 시트가 하나만 들어 있습니다. 어떤 아이디어라도 VBA에 익숙하지 않으므로 도움이됩니다. 그리고 저는 111 번 복사하고 붙여 넣기를 원하지 않습니다.

감사합니다.

Answer 1

나는 최근에 같은 문제가있었습니다. 이 코드 만 있으면됩니다. 폴더를 지정하면 모든 통합 문서가 하나로 통합됩니다 (여러 장이 있어도 처리 할 수 ​​있음).

' found at: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829 

Option Explicit 

'32-bit API declarations 
Declare Function SHGetPathFromIDList Lib "shell32.dll" _ 
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _ 
pszpath As String) As Long 

Declare Function SHBrowseForFolder Lib "shell32.dll" _ 
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _ 
As Long 

Public Type BrowseInfo 
    hOwner As Long 
    pIDLRoot As Long 
    pszDisplayName As String 
    lpszTitle As String 
    ulFlags As Long 
    lpfn As Long 
    lParam As Long 
    iImage As Long 
End Type 

Function GetDirectory(Optional msg) As String 
    On Error Resume Next 
    Dim bInfo As BrowseInfo 
    Dim path As String 
    Dim r As Long, x As Long, pos As Integer 

    'Root folder = Desktop 
    bInfo.pIDLRoot = 0& 

    'Title in the dialog 
    If IsMissing(msg) Then 
     bInfo.lpszTitle = "Please select the folder of the excel files to copy." 
    Else 
     bInfo.lpszTitle = msg 
    End If 

    'Type of directory to return 
    bInfo.ulFlags = &H1 

    'Display the dialog 
    x = SHBrowseForFolder(bInfo) 

    'Parse the result 
    path = Space$(512) 
    r = SHGetPathFromIDList(ByVal x, ByVal path) 
    If r Then 
     pos = InStr(path, Chr$(0)) 
     GetDirectory = Left(path, pos - 1) 
    Else 
     GetDirectory = "" 
    End If 
End Function 

Sub CombineFiles() 
    Dim path   As String 
    Dim FileName  As String 
    Dim LastCell  As range 
    Dim Wkb    As Workbook 
    Dim ws    As Worksheet 
    Dim ThisWB   As String 

    ThisWB = ThisWorkbook.Name 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
    path = GetDirectory 
    FileName = Dir(path & "\*.xls", vbNormal) 
    Do Until FileName = "" 
     If FileName <> ThisWB Then 
      Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName) 
      For Each ws In Wkb.Worksheets 
       Set LastCell = ws.cells.SpecialCells(xlCellTypeLastCell) 
       If LastCell.Value = "" And LastCell.Address = range("$A$1").Address Then 
       Else 
        ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count) 
       End If 
      Next ws 
      Wkb.Close False 
     End If 
     FileName = Dir() 
    Loop 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 

    Set Wkb = Nothing 
    Set LastCell = Nothing 
End Sub 

Answer 2

이것은 더 짧은 버전입니다. 도구/참조를 수행하고 Microsoft Scripting Runtime을 추가해야합니다.

Sub CopySheet1s() 
' Copies first sheet from all workbooks in current path 
' to a new workbook called wbOutput.xlsx 

Dim fso As New Scripting.FileSystemObject  
Dim vFile As Variant, sFile As String, lPos As Long 
Dim wbInput As Workbook, wbOutput As Workbook 
Dim fFolder As Folder 
Const cOUTPUT As String = "wbOutput.xlsx" 

    If fso.FileExists(cOUTPUT) Then 
     fso.DeleteFile cOUTPUT 
    End If 

    Set wbOutput = Workbooks.Add()   

    Set fFolder = fso.GetFolder(ThisWorkbook.Path) 
    For Each vFile In fFolder.Files 
     lPos = InStrRev(vFile, "\") 
     sFile = Mid(vFile, lPos + 1) 
     If sFile <> cOUTPUT And sFile <> ThisWorkbook.Name And Left(sFile, 1) <> "~" Then 
      Set wbInput = Workbooks.Open(Filename:=sFile, ReadOnly:=True) 
      wbInput.Worksheets(1).Copy after:=wbOutput.Worksheets(1) 
      wbInput.Close savechanges:=False 
     End If 
    Next 

    wbOutput.SaveAs Filename:=cOUTPUT 
    wbOutput.Close 

End Sub 

Answer 3

모든 .xls 파일을 하나의 폴더에 저장하고 '파일 경로 입력'에 파일 경로를 입력하고 매크로를 실행하십시오.

Sub GetSheets() 

Path = "C:\Enter Files Path Here\" 

Filename = Dir(Path & "*.xls") 

Do While Filename <> "" 
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True 

For Each Sheet In ActiveWorkbook.Sheets 

Sheet.Copy After:=ThisWorkbook.Sheets(1) 

Next Sheet 

Workbooks(Filename).Close 

Filename = Dir() 

Loop 

End Sub