根据文件名将 excel 个文件合并到一个新的 excel 文件中
Merge excel files into a new excel file based on filename
我有一个文件夹，其中包含大约 500-600 个 excel 文件，这些文件来自我制作的脚本，文件名最终是这样的
101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx
文件名遵循该模式，101a、102a 等。我想做的是将那些基于该模式的文件合并到 1 个 excel 文件中。因此，101a12345.xlsx和101a67899.xlsx应该合并成一个101aMaster.xlsx。所有 excel 个文件都是单个 sheet.
我在这里找到了我正在尝试实现的示例代码：
摘自上面的link：
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 文件时我收到错误消息：运行-time Error '1004' - Method 'Open' of object 'Workbooks'失败。
有没有办法让这段代码起作用？
Excel 版本为 pro plus 2016.
未经测试，但这是一种不会同时打开多个文件的方法：
Sub test(sourceFolder As String, destinationFolder As String)
Dim dict As Object, code As String
Dim colFiles As Collection, f, k, wbNew As Workbook, wb As Workbook
Set dict = VBA.CreateObject("Scripting.Dictionary")
'ensure trailing "\"
EnsureSlash sourceFolder
EnsureSlash destinationFolder
'get a collection of all xlsx files in the source folder
Set colFiles = allFiles(sourceFolder, "*.xlsx")
If colFiles.Count = 0 Then Exit Sub 'no files
'organize the files into groups according to first four characters of the filename
For Each f In colFiles
code = Left(f.Name, 4)
If Not dict.exists(code) Then Set dict(code) = New Collection 'need new group?
dict(code).Add f 'add the file to the collection for this code
Next f
'loop over the groups
For Each k In dict
Set colFiles = dict(k) 'the files for this code
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet) 'one sheet
For Each f In colFiles
With Workbooks.Open(f.Path)
.Worksheets(1).Copy after:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = Replace(f.Name, ".xlsx", "")
.Close False
End With
Next f
Application.DisplayAlerts = False
wbNew.Sheets(1).Delete 'remove the empty sheet
Application.DisplayAlerts = True
wbNew.SaveAs destinationFolder & k & ".xlsx"
wbNew.Close
Next k
End Sub
'Return all files in `sourceFolder` which match `pattern`
' as a collection of file objects
Function allFiles(sourceFolder As String, pattern As String) As Collection
Dim col As New Collection, f
For Each f In CreateObject("scripting.filesystemobject").getfolder(sourceFolder).Files
If f.Name Like pattern Then col.Add f
Next f
Set allFiles = col
End Function
'Utility - check a path ends in a backslash
' use Application.PathSeparator if needs to be cross-platform
Sub EnsureSlash(ByRef f As String)
If Right(f, 1) <> "\" Then f = f & "\"
End Sub
合并工作簿
- 它将打开以唯一的前四个字符开始的每个文件的第一个，并将每个下一个打开的文件的第一个工作表复制到第一个打开的文件，最后将其另存为一个新文件。
- 不必只有 2 个文件（以相同的四个字符开头），只能有一个。
- 调整常量部分中的值。
Option Explicit
Sub mergeWorkbooks()
Const sPath As String = "F:\Test21077087\"
Const sPattern As String = "*.xlsx"
Const dPath As String = "F:\Test21077087\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 Immediate window (CTRL+G)。
Sub listNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
Debug.Print nm.Name
Next nm
End Sub
首先，检查一些公式中是否使用了名称（如果有）。
使用以下命令删除活动工作簿中的所有名称。
Sub deleteNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
End Sub
我有一个文件夹，其中包含大约 500-600 个 excel 文件，这些文件来自我制作的脚本，文件名最终是这样的
101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx
文件名遵循该模式，101a、102a 等。我想做的是将那些基于该模式的文件合并到 1 个 excel 文件中。因此，101a12345.xlsx和101a67899.xlsx应该合并成一个101aMaster.xlsx。所有 excel 个文件都是单个 sheet.
我在这里找到了我正在尝试实现的示例代码：
摘自上面的link：
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 文件时我收到错误消息：运行-time Error '1004' - Method 'Open' of object 'Workbooks'失败。
有没有办法让这段代码起作用？
Excel 版本为 pro plus 2016.
未经测试，但这是一种不会同时打开多个文件的方法：
Sub test(sourceFolder As String, destinationFolder As String)
Dim dict As Object, code As String
Dim colFiles As Collection, f, k, wbNew As Workbook, wb As Workbook
Set dict = VBA.CreateObject("Scripting.Dictionary")
'ensure trailing "\"
EnsureSlash sourceFolder
EnsureSlash destinationFolder
'get a collection of all xlsx files in the source folder
Set colFiles = allFiles(sourceFolder, "*.xlsx")
If colFiles.Count = 0 Then Exit Sub 'no files
'organize the files into groups according to first four characters of the filename
For Each f In colFiles
code = Left(f.Name, 4)
If Not dict.exists(code) Then Set dict(code) = New Collection 'need new group?
dict(code).Add f 'add the file to the collection for this code
Next f
'loop over the groups
For Each k In dict
Set colFiles = dict(k) 'the files for this code
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet) 'one sheet
For Each f In colFiles
With Workbooks.Open(f.Path)
.Worksheets(1).Copy after:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = Replace(f.Name, ".xlsx", "")
.Close False
End With
Next f
Application.DisplayAlerts = False
wbNew.Sheets(1).Delete 'remove the empty sheet
Application.DisplayAlerts = True
wbNew.SaveAs destinationFolder & k & ".xlsx"
wbNew.Close
Next k
End Sub
'Return all files in `sourceFolder` which match `pattern`
' as a collection of file objects
Function allFiles(sourceFolder As String, pattern As String) As Collection
Dim col As New Collection, f
For Each f In CreateObject("scripting.filesystemobject").getfolder(sourceFolder).Files
If f.Name Like pattern Then col.Add f
Next f
Set allFiles = col
End Function
'Utility - check a path ends in a backslash
' use Application.PathSeparator if needs to be cross-platform
Sub EnsureSlash(ByRef f As String)
If Right(f, 1) <> "\" Then f = f & "\"
End Sub
合并工作簿
- 它将打开以唯一的前四个字符开始的每个文件的第一个，并将每个下一个打开的文件的第一个工作表复制到第一个打开的文件，最后将其另存为一个新文件。
- 不必只有 2 个文件（以相同的四个字符开头），只能有一个。
- 调整常量部分中的值。
Option Explicit
Sub mergeWorkbooks()
Const sPath As String = "F:\Test21077087\"
Const sPattern As String = "*.xlsx"
Const dPath As String = "F:\Test21077087\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 Immediate window (CTRL+G)。
Sub listNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
Debug.Print nm.Name
Next nm
End Sub
首先，检查一些公式中是否使用了名称（如果有）。 使用以下命令删除活动工作簿中的所有名称。
Sub deleteNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
End Sub