首页 文章

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

提问于
浏览
0

我正在使用两个宏 . 第一个将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个宏,首先重命名工作表,然后将它们合并到一个文件中 .

这些是我目前使用的宏:

Macro 1 to rename the worksheets:

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

Macro 2 to merge workbooks:

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

2 回答

  • 0

    您可以将它们分开,而不是合并宏,只需将它们从一个中调用:

    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
    
  • 1

    经过一番试验和错误后,我设法将两个宏组合起来 . 我在这里找到了一个类似的问题,并使用了其中一个答案并将其改为我的需求 .

    我将此添加到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
    

    结束子

相关问题