Question

我是在为经理准备报告。我有多个excel文件（总是有一张）我需要根据原始文件的名称将工作表合并到一个具有多个工作表的工作簿（称为与原始工作簿相同）。

我需要它来检查文件的名称，并根据前四个字符合并那些具有相同字符的文件。然后我希望新工作簿以这四个字符的名称保存。

例如，我在一个文件夹中有这些文件 - ＆gt;

1111_AB_ABC

1111_BC_AAA

1222_CD_BBB

1222_KL_XXX

1222_HJ_OPD

1666_HA_BNN

等（大概有300个这样的文件，大多数开头都有3个文件号码相同，但我有四个或五个文件的数字很少）。有没有可能怎么做？

我发现了一些将工作簿合并到一个主文件的帖子，但没有任何关于根据文件名合并文件的内容。

Answer 1

我会给你一些高层次的想法。

为了达到你想要的，你必须这样做：

解析整个目录并检索其包含的所有文件
从文件名中提取子字符串
创建具有给定名称的新工作簿

保存工作簿。

Dim w as Workbook           ' workbook that will contain the sheets
Dim tempWork as Workbook
Dim rootFolder          ' the folder containing your files
Dim fs                  ' represent FileSystem object
Dim folder              ' represent folder object 
Dim files               ' represent all files in a folder
Dim file                ' represent a file object

rootFolder = "C:\path\To\my\folder"
Set fs = CreateObject("Scripting.FileSystemObject")
Set folder = fs.GetFolder(rootFolder)
Set files = folder.Files           ' retrieve only files in rootFolder


For Each file In files
  ' here "file" represent a file in rootFolder
  fileName = file.Name
  firstFourChar = Mid(fileName,1,4)   ' with Mid buil-in function you extract   sub string

  ' your business logic goes here

next

'要创建新工作簿，您可以使用：

Dim w as Workbook
Set w = Workbooks.Add

'用于保存工作簿：

w.save ("path where save")

'打开工作簿：

Set w = Workbooks.Open(rootFolder & "\" & file.Name)

有关Microsoft Visual Basic帮助的详细信息：

Answer 2

以下是执行此操作的代码。

作为参数，您需要将路径传递到源文件夹和应保存结果文件的目标文件夹。

请注意，文件夹路径必须在末尾包含斜杠。您可以稍后修改此函数以检查文件夹路径末尾是否包含斜杠，如果不是则自动添加。

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

如何基于工作簿名称将多个工作簿合并为一个工作簿

2 个答案: