Excel合并文件时自动命名工作表与单元格区域的VBA代码优化问询

以下是修改后的完整代码，已实现你要求的两个功能，同时处理了含日期点号等特殊字符的文件名问题，适配批量处理需求：

Sub Merge_Excel_Files()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim srcFileName As String
    Dim validSheetName As String
    Dim nameExists As Boolean
    Dim nameSuffix As Integer

    fnameList = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsm;*.csv),*.xls;*.xlsx;*.xlsm;*.csv", _
        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)

                ' 提取源文件名（不含路径和扩展名）
                srcFileName = Dir(fnameCurFile)
                srcFileName = Left(srcFileName, InStrRev(srcFileName, ".") - 1)

                ' 处理工作表名非法字符（Excel不允许/:*?"<>|）
                validSheetName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(srcFileName, "/", ""), "\", ""), ":", ""), "*", ""), "?", ""), """", ""), "<", "")
                validSheetName = Replace(Replace(validSheetName, ">", ""), "|", "")
                ' 限制长度不超过31字符（Excel工作表名最大长度）
                If Len(validSheetName) > 31 Then validSheetName = Left(validSheetName, 31)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                    
                    ' 处理重名情况（若已有同名工作表则加序号）
                    nameExists = True
                    nameSuffix = 1
                    Do While nameExists
                        On Error Resume Next
                        nameExists = Not wbkCurBook.Sheets(validSheetName & IIf(nameSuffix > 1, "_" & nameSuffix, "")) Is Nothing
                        On Error GoTo 0
                        If nameExists Then nameSuffix = nameSuffix + 1
                    Loop
                    wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = validSheetName & IIf(nameSuffix > 1, "_" & nameSuffix, "")

                    ' 定义N2:N15区域名称为当前工作表名
                    With wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                        .Names.Add _
                            Name:=.Name, _
                            RefersTo:=.Range("N2:N15"), _
                            Visible:=True
                    End With
                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. 文件名提取与合法性处理

   • 使用Dir函数提取纯文件名，去掉路径和扩展名
   • 替换Excel工作表名不允许的特殊字符（/:*?"<>|）
   • 限制名称长度不超过31字符（Excel工作表名的最大限制）
   • 增加重名检测，若已有同名工作表自动添加序号后缀（如2024.05.20_1）

2. 工作表重命名

   • 复制工作表后立即将其重命名为处理后的合法文件名
   • 自动处理重名场景，避免批量处理时出错

3. 单元格区域命名

   • 复制并重命名工作表后，直接给当前工作表的N2:N15区域定义名称，名称与工作表名完全一致
   • 使用Names.Add方法确保名称全局唯一（若有重名工作表，名称也会带序号后缀）

内容的提问来源于stack exchange，提问作者alxn