VBA创建图纸时出错处理

我正在使用下面的代码，复制一个隐藏的工作表并复制它，重命名is并在两张工作表上填写某些字段

我是这样做的，因为我需要复制隐藏工作表的布局和格式

我遇到的问题是，当我单击“创建”按钮时，如果工作表已经存在，它将完全崩溃Excel，我尝试添加错误处理，但我尝试检查工作表是否存在的所有操作都不起作用，并且仍然崩溃Excel

已分离正在取消隐藏模板工作表的代码，对其进行复制，重命名新工作表，然后重新隐藏模板

我想让它做的是，从TextBox5中检查输入的工作表名称，并检查工作表是否存在，如果它确实显示一个消息框，说明工作表已经存在，如果工作表不存在，则按正常方式执行代码

如果你真的感谢我已经收到的所有帮助和支持，并感谢你们所有人在这方面提供的帮助

   Private Sub CommandButton3_Click()
        Dim wb As Workbook: Set wb = ThisWorkbook
        Dim ws As Worksheet: Set ws = wb.Sheets("Template")
        Dim newws As Worksheet, sh As Worksheet, newname
        Dim query As Long, xst As Boolean, info As String
        Dim NextRow As Long, myCCName As Variant, lastRow2 As Long, lastRow As Long
        'Contract Name
        Dim Contact As String, name As String, name2 As String, SpacePos As Integer
        Dim answer As Integer
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With

    lastRow2 = Sheets("Payment Form").Range("A18:A34").End(xlDown).Row
    lastRow = Sheets("Payment Form").Range("U36:U53").End(xlDown).Row

    'Contract Name
    Set contract = Sheets("Payment Form").Range("C9")
    SpacePos = InStr(contract, "- ")
    name = Left(contract, SpacePos)
    name2 = Right(contract, Len(contract) - Len(name))
    '
    retry:
        xst = False
        newname = Me.TextBox5.Value
        myCCName = Me.TextBox4.Value
        If newname = "" Then
            MsgBox "You have not entered a CC Code Number. Please enter CC Code Number!", vbExclamation, "An Error Occured"
        Exit Sub
        End If
        If myCCName = "" Then
            MsgBox "You have not entered a CC Code Name. Please enter CC Code Name!", vbExclamation, "An Error Occured"
        Exit Sub
        End If
        For Each sh In wb.Sheets
            If sh.name = newname Then
                xst = True: Exit For
            End If
        Next
        If Len(newname) = 0 Or xst = True Then
            info = "Sheet name is invalid. Please retry."
            GoTo retry
        End If

---

我个人使用下面的函数检查工作簿中是否存在工作表allready，在这种情况下返回True：

Public Function doItExist(strSheetName as String) As Boolean
    Dim wsTest As Worksheet: Set wsTest = Nothing

    On Error Resume Next
    Set wsTest = ThisWorkbook.Worksheets(strSheetName)
    On Error GoTo 0

    If wsTest Is Nothing Then
        doExist = False
    Else
        doExist = True
    End If

End Function

我似乎找不到代码的原始源代码，但我不能相信，这只是我在ozgrid或Mrexcel上找到的一些代码的修改版本

编辑：

仔细看看您的代码，您似乎已经准备好检查xst变量中是否存在sheetname。据我所知，如果sheetname无效，用户无法更新，因为重试块将继续循环

在“重试”下：

'### This bit essentially does the same as doSheetExist
For Each sh In wb.Sheets
    If sh.name = newname Then
        xst = True: Exit For
    End If
Next
'###

If Len(newname) = 0 Or xst = True Then 'if you go for the doSheetExist, then the xst check is obsolete. Else move the xst check to the elseif and remove the doSheetExist call
    info = "Sheet name is invalid. Please retry."
    'GoTo retry 'As far as I can tell calling retry would just cause an infinite loop as the user have had no chance to update sheetname
    Exit Sub 'let the user update and click the button again
ElseIf doSheetExist(newname) = True Then
    info = "Sheet name allready exist. Please specify other sheetname"
    Exit Sub
End If

---

在整个代码中，您的“with”语句似乎有一些常见的拼写错误和错误。 我希望能整理并重新编码该函数，但由于它未经测试，我不能保证它能正常工作

我还将工作表检查函数作为一个单独的函数包含在内

Private Sub CommandButton3_Click()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsTemplate As Worksheet: Set wsTemplate = wb.Sheets("Template")
    Dim wsPayment As Worksheet: Set wsPayment = wb.Sheets("Payment Form")
    Dim wsNew As Worksheet

    Dim NewName As String: NewName = Me.TextBox5.Value
    Dim CCName As Variant: CCName = Me.TextBox4.Value

    If NewName = "" Or CCName = "" Then
        MsgBox "CC Code Name or Number missing. Please check details!", vbExclamation, "An Error Occured"
        Exit Sub
    End If

    If WorksheetExists(NewName) Then
        MsgBox "Sheet name already exists. Please retry!", vbExclamation, "An Error Occured"
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With

    Dim lastRow As Long: lastRow = wsPayment.Range("U36:U53").End(xlDown).Row
    Dim lastRow2 As Long: lastRow2 = wsPayment.Range("A18:A34").End(xlDown).Row

    'Contract Name
    Dim Contract As String: Contract = Sheets("Payment Form").Range("C9").Value
    Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
    Dim Name As String: Name = Left(Contract, SpacePos)
    Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))

    wsTemplate.Visible = True
    wsTemplate.Copy before:=Sheets("Details"): Set wsNew = ActiveSheet
    wsTemplate.Visible = False

    With wsPayment
        For Each Cell In .Range("A18:A34")
            If Len(Cell) = 0 Then
                Cell.Value = NewName & " -" & Name2 & ": " & CCName
                Exit For
            End If
        Next Cell
    End With

    With wsNew
        .Name = NewName
        .Range("D4").Value = wsPayment.Range("A18:A34").End(xlDown).Value
        .Range("D6").Value = wsPayment.Range("L11").Value
        .Range("D8").Value = wsPayment.Range("C9").Value
        .Range("D10").Value = wsPayment.Range("C11").Value
    End With

    With wsPayment
        .Range("J" & lastRow2 + 1).Value = 0
        .Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
        .Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
        .Range("U" & lastRow + 1).Value = NewName & ": "
        .Range("V" & lastRow + 1).Formula = "='" & NewName & "'!I21"
        .Range("W" & lastRow + 1).Formula = "='" & NewName & "'!L23"
        .Range("X" & lastRow + 1).Formula = "='" & NewName & "'!K21"
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .CutCopyMode = True
    End With

    Dim Answer As Integer: Answer = MsgBox("Would you like to create another sheet?", _
        vbYesNo + vbQuestion, "New Sheet")
    If Answer = vbNo Then Unload Me

    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
    On Error GoTo 0
End Function

Private子命令按钮3\u单击（）
将wb设置为工作簿：设置wb=ThisWorkbook
将wsTemplate设置为工作表：设置wsTemplate=wb.Sheets（“模板”）
将wsPayment设置为工作表：设置wsPayment=wb.Sheets（“付款单”）
新建为工作表
Dim NewName作为字符串：NewName=Me.TextBox5.Value
尺寸CCName作为变量：CCName=Me.TextBox4.Value
如果NewName=“”或CCName=“”，则
MsgBox“缺少CC代码名或编号。请检查详细信息！”，VBEQUOTE，“发生错误”
出口接头
如果结束
如果工作表列表（新名称），则
MsgBox“工作表名称已存在。请重试！”，VBEQUOTE，“发生错误”
出口接头
如果结束
应用
.ScreenUpdate=False
.EnableEvents=False
.CutCopyMode=False
以
Dim lastRow的长度：lastRow=wsPayment.Range（“U36:U53”）.End（xlDown）.Row
Dim lastRow2的长度：lastRow2=wsPayment.Range（“A18:A34”）.End（xlDown）.Row
“合同名称
Dim合同作为字符串：合同=表格（“付款形式”）。范围（“C9”）。值
Dim SpacePos为整数：SpacePos=InStr（合同号“-”）
作为字符串的Dim名称：名称=左（合同，SpacePos）
Dim Name2作为字符串：Name2=右侧（合同，Len（合同）-Len（名称））
wsTemplate.Visible=True
wsTemplate.Copy before:=工作表（“详细信息”）：设置wsNew=ActiveSheet
wsTemplate.Visible=False
付款
范围内的每个单元格（“A18:A34”）
如果Len（Cell）=0，则
Cell.Value=NewName&“-”&Name2&“：”&CCName
退出
如果结束
下一个细胞
以
与wsNew
.Name=NewName
.Range（“D4”）.Value=wsPayment.Range（“A18:A34”）.End（xlDown）.Value
.Range（“D6”）.Value=wsPayment.Range（“L11”）.Value
.Range（“D8”）.Value=wsPayment.Range（“C9”）.Value
.Range（“D10”）.Value=wsPayment.Range（“C11”）.Value
以
付款
.Range（“J”&lastRow2+1）。值=0
.Range（“L”和lastRow2+1）。公式=“=N”和lastRow2+1&“-J”和lastRow2+1&”
.Range（“N”&lastRow2+1）。公式=“=”&NewName&“！L20”
.Range（“U”和lastRow+1）。值=新名称和“：”
.Range（“V”&lastRow+1）。公式=“=”&NewName&“！I21”
.Range（“W”&lastRow+1）。公式=“=”&NewName&“！L23”
.Range（“X”&lastRow+1）。公式=“=”&NewName&“！K21”
以
应用
.ScreenUpdate=True
.EnableEvents=True
.CutCopyMode=True
以
将答案设置为整数：Answer=MsgBox（“是否要创建另一张工作表？”_
vbYesNo+vbQuestion，“新表”）
如果答案=vbNo，则卸载我
Me.TextBox4.Value=“”
Me.TextBox5.Value=“”
端接头
作为布尔值的公共函数工作表列表（ByVal工作表名称为字符串）
出错时继续下一步
工作表列表=（ThisWorkbook.Sheets（工作表名称）.Name“”）
错误转到0
端函数

Andreas N.您好，谢谢您的支持，我该如何在我使用的代码中运行它？？感谢仔细查看，似乎您已准备好对sheetname进行有效检查，但“转到重试”将继续循环，因为用户将没有机会更新newnameFlephal。真是太感谢你了！！！！这使得代码更加稳定，现在运行更加流畅！我真的感谢所有的帮助！

'### This bit essentially does the same as doSheetExist
For Each sh In wb.Sheets
    If sh.name = newname Then
        xst = True: Exit For
    End If
Next
'###

If Len(newname) = 0 Or xst = True Then 'if you go for the doSheetExist, then the xst check is obsolete. Else move the xst check to the elseif and remove the doSheetExist call
    info = "Sheet name is invalid. Please retry."
    'GoTo retry 'As far as I can tell calling retry would just cause an infinite loop as the user have had no chance to update sheetname
    Exit Sub 'let the user update and click the button again
ElseIf doSheetExist(newname) = True Then
    info = "Sheet name allready exist. Please specify other sheetname"
    Exit Sub
End If

Private Sub CommandButton3_Click()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsTemplate As Worksheet: Set wsTemplate = wb.Sheets("Template")
    Dim wsPayment As Worksheet: Set wsPayment = wb.Sheets("Payment Form")
    Dim wsNew As Worksheet

    Dim NewName As String: NewName = Me.TextBox5.Value
    Dim CCName As Variant: CCName = Me.TextBox4.Value

    If NewName = "" Or CCName = "" Then
        MsgBox "CC Code Name or Number missing. Please check details!", vbExclamation, "An Error Occured"
        Exit Sub
    End If

    If WorksheetExists(NewName) Then
        MsgBox "Sheet name already exists. Please retry!", vbExclamation, "An Error Occured"
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With

    Dim lastRow As Long: lastRow = wsPayment.Range("U36:U53").End(xlDown).Row
    Dim lastRow2 As Long: lastRow2 = wsPayment.Range("A18:A34").End(xlDown).Row

    'Contract Name
    Dim Contract As String: Contract = Sheets("Payment Form").Range("C9").Value
    Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
    Dim Name As String: Name = Left(Contract, SpacePos)
    Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))

    wsTemplate.Visible = True
    wsTemplate.Copy before:=Sheets("Details"): Set wsNew = ActiveSheet
    wsTemplate.Visible = False

    With wsPayment
        For Each Cell In .Range("A18:A34")
            If Len(Cell) = 0 Then
                Cell.Value = NewName & " -" & Name2 & ": " & CCName
                Exit For
            End If
        Next Cell
    End With

    With wsNew
        .Name = NewName
        .Range("D4").Value = wsPayment.Range("A18:A34").End(xlDown).Value
        .Range("D6").Value = wsPayment.Range("L11").Value
        .Range("D8").Value = wsPayment.Range("C9").Value
        .Range("D10").Value = wsPayment.Range("C11").Value
    End With

    With wsPayment
        .Range("J" & lastRow2 + 1).Value = 0
        .Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
        .Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
        .Range("U" & lastRow + 1).Value = NewName & ": "
        .Range("V" & lastRow + 1).Formula = "='" & NewName & "'!I21"
        .Range("W" & lastRow + 1).Formula = "='" & NewName & "'!L23"
        .Range("X" & lastRow + 1).Formula = "='" & NewName & "'!K21"
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .CutCopyMode = True
    End With

    Dim Answer As Integer: Answer = MsgBox("Would you like to create another sheet?", _
        vbYesNo + vbQuestion, "New Sheet")
    If Answer = vbNo Then Unload Me

    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
    On Error GoTo 0
End Function