将工作表导入一个 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