ワークシートを1つのExcelワークブックにインポートする

Question

私は111 Excelブックを含むフォルダを持っています。私はすべてのファイルを1つのExcelファイルにコピーして別のシートに貼り付けたいと思っています。したがって、1枚のシートには1つのファイルの内容が必要です。各ファイルには1枚のシートしか含まれていません。私はVBAに精通していないので、どんなアイデアであれ助けてくれるでしょう。そして、私は111回コピー＆ペーストしたくありません。

ありがとうございました。

Answer 1

私は最近同じ問題を抱えていました。このコードはあなたが必要とするものです。フォルダを指定すると、すべてのワークブックが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

これは短いバージョンです。 Tools/Referencesを実行し、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ファイルを1つのフォルダに配置し、ファイルパスをここに入力して、マクロを実行します。

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