导入其他Excel工作簿前清除格式的VBA代码问题咨询

修改后的完整代码 #

Sub add()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Dim FNames As Variant
    Dim Cnt As Long
    Dim MstWbk As Workbook
    Dim ws As Worksheet
    Dim importedWs As Worksheet
    
    Set MstWbk = ThisWorkbook

    ' 启用错误捕获，出错时跳转处理
    On Error GoTo ErrorHandler

    FNames = Application.GetOpenFilename(fileFilter:="Excel files (*.xls*), *.xls*", MultiSelect:=True, Title:="选择文件")
    If Not IsArray(FNames) Then Exit Sub
    
    For Cnt = 1 To UBound(FNames)
        Set ws = Workbooks.Open(FNames(Cnt)).Sheets(1)
        
        ' 清除源工作表的超链接和所有格式，保留单元格内容
        ws.Cells.ClearHyperlinks
        ws.Cells.ClearFormats
        
        ' 复制工作表到主工作簿
        ws.Copy After:=MstWbk.Sheets(MstWbk.Sheets.Count)
        Set importedWs = MstWbk.Sheets(MstWbk.Sheets.Count)
        
        ' 优化命名逻辑：取文件名（不含后缀），兼容无点的文件名
        importedWs.Name = Left(ws.Parent.Name, InStrRev(ws.Parent.Name, ".") - 1)
        
        ws.Parent.Close False
    Next Cnt

    MsgBox "导入完成！", vbInformation

ExitSub:
    ' 恢复Excel默认设置，无论成功失败都执行
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub

ErrorHandler:
    MsgBox "导入第" & Cnt & "个文件时出错：" & Err.Description, vbCritical
    Resume ExitSub
End Sub

关键改动说明 #

• 添加错误捕获机制：移除注释的On Error Resume Next，改用On Error GoTo ErrorHandler，出错时会弹出明确的错误信息，告知哪个文件出问题及原因，解决了之前无通知的问题。
• 导入前清除源文件格式：在复制工作表前，调用ClearHyperlinks和ClearFormats清除源工作表的超链接和所有格式（字体、颜色、边框等），只保留单元格内容，从根源避免格式过多导致的导入异常。
• 优化工作表命名逻辑：用InStrRev查找文件名中最后一个点的位置，替代原来的InStr(2,...)，避免文件名中包含多个点或无点时出现命名错误。
• 确保环境恢复：新增ExitSub标签，无论导入成功还是出错，都会恢复Excel的ScreenUpdating和DisplayAlerts设置，避免Excel一直处于静默或不刷新状态。

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