如何根据工作簿名称将多个工作簿合并为一个工作簿

我正在为经理准备报告。 我有多个Excel文件（总是用一张纸）我需要合并工作表到一个工作簿与多个工作表（称为原始工作簿相同）基于原始文件的名称。

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

例如我有一个文件夹中的这些文件 – >

1111_AB_ABC 1111_BC_AAA 1222_CD_BBB 1222_KL_XXX 1222_HJ_OPD 1666_HA_BNN 

（这里有大约300个文件，其中大部分是3个文件，开始时数字相同，但是有四个或五个文件的数字很less）。 有没有可能如何做到这一点？

我发现一些post合并工作簿到一个主文件，但没有什么是关于合并基于文件名的文件。

Answer 1

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

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

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

 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 

Answer 2

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

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

• parsing整个目录并检索它包含的所有文件
• 从文件名中提取子string
• 用给定的名字创build新的工作簿

• 保存一个工作簿。

   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 

  '为了创build一个新的工作簿，你可以使用：

   Dim w as Workbook Set w = Workbooks.Add 

  '保存工作簿：

   w.save ("path where save") 

  “打开工作簿：

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

有关Microsoft visual basic帮助的更多信息：