根据文件名将Excel文件合并到新的Excel文件中 [英] Merge excel files into a new excel file based on filename

问题描述

我有一个文件夹，其中包含我制作的脚本中约500-600个excel文件，文件名最终像这样

I have a folder containing about 500-600 excel files from a script I have made where the file names end up like this

101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx

文件名遵循该模式，101a，102a等.我要执行的操作是将基于该模式的文件合并到1个excel文件中.因此，101a12345.xlsx和101a67899.xlsx应该合并为101aMaster.xlsx.所有的excel文件都是单张纸.

The file names follow that patern, 101a, 102a etc. What i want to do is merge those based on that paternt into 1 excel file. Therefore, the 101a12345.xlsx and 101a67899.xlsx should merge into an 101aMaster.xlsx. All excel files are single sheet.

我在此处找到了要尝试实现的示例代码:

I have found a sample code here which i am trying to implement: How to merge multiple workbooks into one based on workbooks names

取自上面的链接:

Sub test(sourceFolder As String, destinationFolder As String)
    Const TO_DELETE_SHEET_NAME As String = "toBeDeleted"
    '------------------------------------------------------------------
    Dim settingSheetsNumber As Integer
    Dim settingDisplayAlerts As Boolean
    Dim dict As Object
    Dim wkbSource As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim filepath As String
    Dim code As String * 4
    Dim wkbDestination As Excel.Workbook
    Dim varKey As Variant
    '------------------------------------------------------------------


    'Change [SheetsInNewWorkbook] setting of Excel.Application object to
    'create new workbooks with a single sheet only.
    With Excel.Application
        settingDisplayAlerts = .DisplayAlerts
        settingSheetsNumber = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .DisplayAlerts = False
    End With


    Set dict = VBA.CreateObject("Scripting.Dictionary")


    filepath = Dir(sourceFolder)

    'Loop through each Excel file in folder
    Do While filepath <> ""

        If VBA.Right$(filepath, 5) = ".xlsx" Then

            Set wkbSource = Excel.Workbooks.Open(sourceFolder & filepath)
            Set wks = wkbSource.Worksheets(1)
            code = VBA.Left$(wkbSource.Name, 4)


            'If this code doesn't exist in the dictionary yet, add it.
            If Not dict.exists(code) Then
                Set wkbDestination = Excel.Workbooks.Add
                wkbDestination.Worksheets(1).Name = TO_DELETE_SHEET_NAME
                Call dict.Add(code, wkbDestination)
            Else
                Set wkbDestination = dict.Item(code)
            End If

            Call wks.Copy(Before:=wkbDestination.Worksheets(1))
            wkbDestination.Worksheets(1).Name = VBA.Mid$(filepath, 6)

            Call wkbSource.Close(False)

        End If

        filepath = Dir

    Loop


    'Save newly created files.
    For Each varKey In dict.keys
        Set wkbDestination = dict.Item(varKey)

        'Remove empty sheet.
        Set wks = Nothing
        On Error Resume Next
        Set wks = wkbDestination.Worksheets(TO_DELETE_SHEET_NAME)
        On Error GoTo 0

        If Not wks Is Nothing Then wks.Delete


        Call wkbDestination.SaveAs(Filename:=destinationFolder & varKey & ".xlsx")


    Next varKey


    'Restore Excel.Application settings.
    With Excel.Application
        .DisplayAlerts = settingDisplayAlerts
        .SheetsInNewWorkbook = settingSheetsNumber
    End With


End Sub

但是，此代码打开了所有工作簿，并且在大约60-70个打开的excel文件中出现错误:运行时错误'1004'-对象'工作簿'的方法'打开'失败.

However, this code opens all workbooks and at about 60-70 open excel files i receive an error: Run-time Error '1004' - Method 'Open' of object 'Workbooks' failed.

有没有办法使此代码有效?

is there a way to make this code work?

Excel版本是pro plus 2016.

Excel version is pro plus 2016.

推荐答案

合并工作簿

• 它将打开每个文件的第一个，以唯一的前四个字符开头，然后将每个下一个打开的文件的第一个工作表复制到第一个打开的文件，最后将其另存为新文件.
• 不必只有2个文件(以相同的四个字符开头)，也可以只有一个.
• 调整常量部分中的值.

Option Explicit

Sub mergeWorkbooks()
    
    Const sPath As String = "F:\Test\2021\67077087\"
    Const sPattern As String = "*.xlsx"
    Const dPath As String = "F:\Test\2021\67077087\Destination\"
    Const dName As String = "Master.xlsx"
    Const KeyLen As Long = 4
    
    Dim PatLen As Long: PatLen = Len(sPattern)
    Dim fName As String: fName = Dir(sPath & sPattern)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do While Len(fName) > 0
        dict(Left(fName, KeyLen)) = Empty
        fName = Dir
    Loop
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    MkDir dPath
    On Error GoTo 0
    
    Dim wb As Workbook
    Dim Key As Variant
    Dim wsLen As Long
    
    For Each Key In dict.Keys
        Set wb = Nothing
        fName = Dir(sPath & Key & sPattern)
        Do While Len(fName) > 0
            wsLen = Len(fName) - PatLen - KeyLen + 2
            If wb Is Nothing Then
                Set wb = Workbooks.Open(sPath & fName)
                wb.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
                'Debug.Print wb.Name
            Else
                With Workbooks.Open(sPath & fName)
                    'Debug.Print .Name
                    .Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
                    .Worksheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
                    .Close False
                End With
            End If
            fName = Dir
        Loop
        Application.DisplayAlerts = False
        wb.SaveAs dPath & Key & dName ', xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        wb.Close False
    Next Key

    Application.ScreenUpdating = True

End Sub

测试名称

使用以下命令将活动工作簿中的所有名称打印到 VBE立即窗口( CTRL + G ).

Use the following to print all names in the active workbook to the VBE Immediate window (CTRL+G).

Sub listNames()
    Dim nm As Name
    For Each nm In ActiveWorkbook.Names
        Debug.Print nm.Name
    Next nm
End Sub

首先，检查是否在某些公式中使用了名称(如果有).使用以下命令删除活动工作簿中的所有名称.

First, check if the names (if any) are used in some formulas. Use the following to delete all names in the active workbook.

Sub deleteNames()
    Dim nm As Name
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next nm
End Sub

这篇关于根据文件名将Excel文件合并到新的Excel文件中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！