Excel VBA - 组合宏以重命名工作表和宏以将工作表合并到一个宏中

Question

我正在使用两个宏。 将 Excel 文件的工作表重命名为工作簿名称的第一个宏。第二个宏将这些重命名的工作簿(仅包含一个工作表(合并到一个工作簿中。每个重命名的工作簿都是由第二个宏创建的新工作簿中的单独选项卡。

其中一个文件的名称示例：AA_aaa##123456789-123456789。 在重命名宏中，我从名称中删除了最后一个字符，因此工作表被命名为 AA_aaa。所有文件都有不同的名称，但都具有相同的格式和长度。

对于第一个宏，我打开每个 excel 文件，运行宏并关闭并再次保存 excel 文件。对于第二个宏，我打开一个仅包含合并宏的 exmpy excel 文件。我从这个文件运行合并宏，它要求我选择要合并的文件。我要合并的文件需要此时关闭。

我采取的步骤顺序是：
1.我打开要为其重命名工作表的 excel 文件。
2.我运行重命名宏(我打开了另一个包含要重命名的宏的excel，因此我可以从那里选择它(。
3.我使用重命名的工作表保存并关闭工作簿。
4.我对所有其他excel文件执行相同的操作(我通常一次重命名大约10个文件(。
5. 我打开一个包含合并宏的 Excel 文件(excel 文件中没有数据(。
6.我运行合并宏。
7.宏要求我选择要合并的文件(这些是我在前面的步骤中重命名的10个文件(。
8.我选择在第一步中重命名的文件。

结果：我现在有一个包含多个工作表的文件，这些工作表包含我重命名的文件中的数据，每个工作表的名称都是原始文件的名称！

我每天需要做大约 20 次这个过程。特别是步骤1(重命名工作表(花费了大量时间，因为我需要单独打开和保存每个文件。我希望有人可以帮助我将这两个宏合二为一。目的是运行 1 个宏，该宏首先重命名工作表，然后将它们合并到一个文件中。

这些是我目前使用的宏：

宏 1 重命名工作表：

Sub RenameSheet()
Dim myname
myname = Replace(ActiveWorkbook. Name, ".xls", "")
ActiveSheet.Select
Activesheet.Name = Left$(Activeworkbook.Name, InStrRev(Activeworkbook.Name,".")-22)
Range("A1").Select
End Sub

宏 2 合并工作簿：

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

Answer 1

与其合并宏，不如将它们分开，然后从一个宏中将它们调用在一起：

Sub RunMyMacros()
RenameSheet
MergeExcelFiles
End Sub

在您的情况下，我认为这将是最干净的解决方案。合并它们不会提高性能。

如果你真的需要将它们组合起来，我想它看起来像这样 - 注意，我已经对一些基本上无用的行发表了一些评论：

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
Dim myname
'Rename sheet
myname = Replace(ActiveWorkbook.Name, ".xls", "")
'ActiveSheet.Select     'this serves no purpose
ActiveSheet.Name = Left$(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 22)
Range("A1").Select 'I don't think this does anything for you either
'Merge excel files
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

Answer 2

经过相当多的试验和错误，我设法将两个宏结合起来。我在这里发现了一个类似的问题，并使用了其中一个答案并将其更改为我的需求。

我将其添加到 MergeExcelFiles 宏中：

wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left$(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 22)

现在，在执行宏以合并文件时重命名文件：

Sub MergeAndRenameExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left$(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 22)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If

结束子