Excel VBA无法按组名匹配形状组问题求助

问题根源分析 #

你的代码存在几个关键错误，导致无法正确定位形状组：

• 无效的工作表引用：sourceSheet(Doorwithfitting).Shapes(groupName)中的Doorwithfitting是未定义变量，遍历工作表时直接用sourceSheet.Shapes(groupName)即可。
• 源工作簿打开逻辑混乱：先执行打开操作再检查文件是否已打开，会引发不必要的错误，且逻辑冗余。
• 未定义的目标工作簿变量：targetWorkbook未声明就直接使用，应改用已定义的targetWorksheet。
• 无意义的遍历延续：找到目标形状组后未退出循环，会浪费资源。

修正后的完整代码 #

Sub InsertShapeGroupBasedOnCondition()
    Dim sourceWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim condition As String
    Dim groupName As String
    Dim shapeExists As Boolean
    Dim sourceSheet As Worksheet
    Dim sourceShape As Shape
    
    condition = ThisWorkbook.Sheets("Operating").Range("C2").Value
    shapeExists = False
    
    ' 先检查源工作簿是否已打开
    On Error Resume Next
    Set sourceWorkbook = Workbooks("Testformacro.xlsx")
    On Error GoTo 0
    
    ' 未打开则尝试打开
    If sourceWorkbook Is Nothing Then
        On Error Resume Next
        Set sourceWorkbook = Workbooks.Open("Z:\999 Program Drawing\Testformacro.xlsx")
        On Error GoTo 0
    End If

    If sourceWorkbook Is Nothing Then
        MsgBox "Source workbook not found."
        Exit Sub
    End If
       
    Set targetWorksheet = ThisWorkbook.Sheets("Operating")

    Select Case condition
        Case "Rectangle"
            groupName = "Rectangle"
        Case "Door2fitting2holes"
            groupName = "Door2fitting2holes"
        Case "Door3fitting3holes"
            groupName = "Door3fitting3holes"
        Case Else
            MsgBox "Input condition not recognized."
            Exit Sub
    End Select
    
    ' 遍历源工作簿所有工作表查找形状组
    For Each sourceSheet In sourceWorkbook.Sheets
        On Error Resume Next
        Set sourceShape = sourceSheet.Shapes(groupName)
        On Error GoTo 0

        If Not sourceShape Is Nothing Then
            ' 复制并粘贴到目标位置
            sourceShape.Copy
            targetWorksheet.Range("H5").PasteSpecial
            shapeExists = True
            Exit For ' 找到后退出循环，避免重复操作
        End If
    Next sourceSheet

    If Not shapeExists Then
        MsgBox "No shape groups found in the source workbook for the specified condition."
    End If
    Application.CutCopyMode = False
End Sub

关键修改说明 #

1. 修正工作表引用：将sourceSheet(Doorwithfitting).Shapes(groupName)改为sourceSheet.Shapes(groupName)，直接使用当前遍历的工作表对象。
2. 优化源工作簿打开逻辑：先检查文件是否已打开，未打开时再执行打开操作，避免重复打开引发错误。
3. 替换目标引用：用已定义的targetWorksheet替代未声明的targetWorkbook，确保引用正确。
4. 添加循环退出逻辑：找到目标形状组后执行Exit For，终止后续不必要的工作表遍历。

内容的提问来源于stack exchange，提问作者ธยาน์ เวศกิจกุล