将工作表导入到一个excel工作簿中

Question

我有一个包含111个excel工作簿的文件夹。我想将每个文件复制并粘贴到一个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脚本运行时。

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