vba 将多个 Excel 文件中的特定工作表导入一个主 Excel 文件

Importing the a specific worksheet from several excel files into one master excel file

提问by lauhub

One of my friends needs to import concatenate the data of some files.

我的一位朋友需要导入连接一些文件的数据。

Let us say each files is into a directory IMPORT_DIR.

假设每个文件都放入一个目录 IMPORT_DIR 中。

Each file as a name like : "NAME_OF_TEAMMATE - 2013.xlsx"

每个文件的名称类似于：“NAME_OF_TEAMMATE - 2013.xlsx”

Each file contains a worksheet for each month of the year : January, February, March, ..., October, November, December.

每个文件都包含一年中每个月的工作表：一月、二月、三月、...、十月、十一月、十二月。

We would like to import the September worksheet of each file.

我们想导入每个文件的九月工作表。

If possible, we would like to choose which worksheet (January,...December) to import from a list.

如果可能，我们希望从列表中选择要导入的工作表（一月、...十二月）。

All the worksheet would be added to a master file. Let us say: "September 2013 - synthesis.xlsx"

所有工作表都将添加到主文件中。让我们说：“2013 年 9 月 - 合成.xlsx”

Each worksheet into the target file should have NAME_OF_TEAMMATE set as its title.

目标文件中的每个工作表都应将 NAME_OF_TEAMMATE 设置为其标题。

I am not a VB developper so I would like to know:

我不是 VB 开发人员，所以我想知道：

• which functions to use to retrieve files list in a directory
• which functions to use to display a dialog box with a list of months to select the month to import
• which functions would help in splitting the VB filename to get the name of teammate as the worksheet
• How to select the source directory where the files to import are
• how to copy a worksheet from another file to the master (or current) file

• 哪些函数用于检索目录中的文件列表
• 使用哪些函数来显示带有月份列表的对话框以选择要导入的月份
• 哪些函数将有助于拆分 VB 文件名以获取队友的名称作为工作表
• 如何选择要导入的文件所在的源目录
• 如何将工作表从另一个文件复制到主（或当前）文件

回答by Netloh

If I understand you correctly, you got a bunch of Excel documents in a folder and you want to copy all of the sheets (with identical names) from these individual files into one master file. This can be done in a more or less fancy manner, but the following code (copied into a workbook module) should do the trick.

如果我理解正确的话，您在一个文件夹中有一堆 Excel 文档，并且您想将所有工作表（具有相同名称）从这些单个文件复制到一个主文件中。这可以以或多或少的奇特方式完成，但以下代码（复制到工作簿模块中）应该可以解决问题。

It basically takes all the files (in this case .xlsx) in a folder and copies all the sheets named "September" into the file where the code is executed from. This is not a very foul proof code since error handling is very basic. But this could get you started on developing a more robust code for getting the job done.

它基本上获取文件夹中的所有文件（在本例中为 .xlsx），并将所有名为“September”的工作表复制到执行代码的文件中。由于错误处理是非常基本的，因此这不是一个非常防伪的代码。但这可以让您开始开发更强大的代码来完成工作。

Option Explicit

Sub ImportSheet()
    Dim i As Integer
    Dim SourceFolder As String
    Dim FileList As Variant
    Dim GrabSheet As String
    Dim FileType As String
    Dim ActWorkBk As String
    Dim ImpWorkBk As String
    Dim NoImport As Boolean

    'Define folder location (and filetypes)
    SourceFolder = "C:\"
    FileType = "*.xlsx"

    'Define sheetname to copy
    GrabSheet = "September"

    'Creates list with filenames
    FileList = ListFiles(SourceFolder & "/" & FileType)

    'Imports data
    Application.ScreenUpdating = False
    ActWorkBk = ActiveWorkbook.Name
    NoImport = False

    For i = 1 To UBound(FileList)
        'Opens file
        Workbooks.Open (SourceFolder & "\" & FileList(i))
        ImpWorkBk = ActiveWorkbook.Name

        'Checks to see if the specific sheet exists in the workbook
        On Error Resume Next
            ActiveWorkbook.Sheets(GrabSheet).Select
            If Err > 0 Then
                NoImport = True
                GoTo nxt
            End If
            Err.Clear
        On Error GoTo 0

        'Copies sheet
        ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)

        'Renames the imported sheet
        On Error Resume Next
            ActiveSheet.Name = FileList(i) & " - " & GrabSheet
            Err.Clear
        On Error GoTo 0

nxt:
        'Closes importfile
        Workbooks(ImpWorkBk).Activate
        Application.DisplayAlerts = False
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True
        Workbooks(ActWorkBk).Activate

    Next i

    'Error if some sheets were not found
    If NoImport = True Then MsgBox "One or more sheets could not be found and imported!"

    Application.ScreenUpdating = True
End Sub


'Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
    Dim GetFileNames() As Variant
    Dim i As Integer
    Dim FileName As String

    On Error GoTo ErrHndlr

    i = 0
    FileName = Dir(Source)
    If FileName = "" Then GoTo ErrHndlr

    'Loops until no more mathing files are found
    Do While FileName <> ""
        i = i + 1
        ReDim Preserve GetFileNames(1 To i)
        GetFileNames(i) = FileName
        FileName = Dir()
    Loop
    ListFiles = GetFileNames
    On Error GoTo 0
    Exit Function

    'If error
ErrHndlr:
    ListFiles = False
    On Error GoTo 0
End Function