时间戳

首页 > 解决方案 > Excel VBA - 组合宏以重命名工作表和宏以将工作表合并到一个宏中

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

问题描述

我正在使用两个宏。第一个将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

标签： vbaexcel

解决方案

您可以将它们分开并从一个中调用它们，而不是合并宏：

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

推荐阅读