Question

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

让我们说每个文件都在IMPORT_DIR目录中。

每个文件的名称如下：“NAME_OF_TEAMMATE - 2013.xlsx”

每个文件都包含一年中每个月的工作表：1月，2月，3月，...，10月，11月，12月。

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

如果可能，我们希望从列表中选择要导入的工作表（1月，12月）。

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

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

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

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

Answer 1

如果我理解正确，您在文件夹中获得了大量Excel文档，并且您希望将这些单个文件中的所有工作表（具有相同名称）复制到一个主文件中。这可以用或多或少花哨的方式完成，但是下面的代码（复制到工作簿模块中）应该可以解决问题。

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

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

将特定工作表从多个Excel文件导入一个主Excel文件

1 个答案: