在已关闭工作簿中查找指定名称工作表并复制到活动工作簿

需求说明 #

• 从活动工作簿SD093_W.xlsm的Sheet1中遍历E列（E2:E15），提取唯一值sysnum
• 读取每个sysnum对应行的D列值作为wsName
• 打开已关闭的工作簿Specification and Configuration Document.xlsx，定位到名为wsName的工作表
• 将该工作表复制到活动工作簿，并重命名为sysnum

原代码问题分析 #

1. SheetExists函数每次调用都会重复打开目标工作簿，造成资源浪费
2. 复制工作表的逻辑错误，当前代码是从活动工作簿复制，而非目标工作簿
3. 错误处理不严谨，On Error Resume Next滥用导致潜在问题无法被捕获
4. 全局变量冗余，可改用局部变量提升代码健壮性
5. IsError的用法错误，未正确判断Match函数的返回结果

修改后的完整代码 #

Public Sub Main()
    Dim wbActive As Workbook, wbSource As Workbook
    Dim wsData As Worksheet, wsCopied As Worksheet
    Dim cell As Range
    Dim dictUnique As Object
    Dim sysnum As String, wsName As String
    Dim specMinCol As Variant, specMaxCol As Variant, formulaCol As Variant
    Dim sourceFilePath As String
    
    ' 初始化活动工作簿和数据工作表
    Set wbActive = ThisWorkbook
    Set wsData = wbActive.Worksheets("Sheet1")
    Set dictUnique = CreateObject("Scripting.Dictionary")
    
    ' 目标工作簿路径
    sourceFilePath = "Specification and Configuration Document.xlsx"
    
    ' 仅打开一次目标工作簿（如果未打开）
    On Error Resume Next
    Set wbSource = Workbooks(sourceFilePath)
    On Error GoTo 0
    If wbSource Is Nothing Then
        Set wbSource = Workbooks.Open(Filename:=sourceFilePath, ReadOnly:=True)
    End If
    
    ' 遍历E列获取唯一值
    For Each cell In wsData.Range("E2:E15").Cells
        sysnum = Trim(cell.Value)
        ' 跳过空值
        If sysnum = "" Then GoTo NextCell
        
        ' 处理唯一值
        If Not dictUnique.Exists(sysnum) Then
            dictUnique.Add sysnum, True
            
            ' 检查活动工作簿中是否已存在同名工作表
            If SheetExistsInWorkbook(sysnum, wbActive) Then
                MsgBox "工作表 '" & sysnum & "' 已存在，跳过复制", vbInformation
                GoTo NextCell
            End If
            
            ' 获取源工作表名称
            wsName = Trim(cell.EntireRow.Columns("D").Value)
            If wsName = "" Then
                MsgBox "行 " & cell.Row & " 的D列为空，无法获取源工作表名称", vbExclamation
                GoTo NextCell
            End If
            
            ' 检查源工作簿中是否存在目标工作表
            If SheetExistsInWorkbook(wsName, wbSource) Then
                ' 复制工作表到活动工作簿
                wbSource.Worksheets(wsName).Copy After:=wsData
                Set wsCopied = wbActive.Worksheets(wsData.Index + 1)
                ' 重命名工作表
                wsCopied.Name = sysnum
                
                ' 查找表头列（优化错误处理）
                specMinCol = Application.Match("SPEC min", wsCopied.Range("A2:Q2"), 0)
                specMaxCol = Application.Match("SPEC max", wsCopied.Range("A2:Q2"), 0)
                formulaCol = Application.Match("Formula / step size", wsCopied.Range("A2:Q2"), 0)
                
                ' 可在此处添加后续处理逻辑，比如使用找到的列索引
                ' 示例：If Not IsError(specMinCol) Then Debug.Print "SPEC min列索引：" & specMinCol
            Else
                MsgBox "源工作簿中不存在工作表 '" & wsName & "'，跳过复制", vbExclamation
            End If
        End If
        
NextCell:
    Next cell
    
    ' 关闭源工作簿（如果是我们打开的）
    If Not wbSource Is Nothing Then
        wbSource.Close SaveChanges:=False
    End If
    
    Set wbActive = Nothing
    Set wbSource = Nothing
    Set wsData = Nothing
    Set wsCopied = Nothing
    Set dictUnique = Nothing
End Sub

' 检查指定工作簿中是否存在目标工作表
Function SheetExistsInWorkbook(sheetName As String, targetWB As Workbook) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = targetWB.Worksheets(sheetName)
    On Error GoTo 0
    SheetExistsInWorkbook = Not ws Is Nothing
End Function

关键修改点 #

• 优化工作簿打开逻辑：仅打开一次源工作簿，避免重复操作，最后自动关闭（只读打开防止修改源文件）
• 拆分工作表检查函数：新增SheetExistsInWorkbook函数，可指定检查的工作簿，区分源工作簿和活动工作簿的检查
• 完善错误处理：添加空值判断、工作表不存在提示，避免代码崩溃
• 规范变量使用：移除全局变量，改用局部变量，提升代码可维护性
• 修正复制逻辑：从源工作簿复制工作表到活动工作簿，而非原代码的当前工作簿内复制
• 正确使用IsError：可在后续逻辑中用IsError判断Match结果是否有效

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