VBA创build表，错误handeling

我使用下面的代码，复制一个隐藏的工作表并复制它，重命名并填写在两张表中的某些领域。

我已经这样做了，因为我需要复制隐藏表格的布局和格式。

我遇到的问题是，当我点击创buildbutton，如果工作表已经退出，它完全崩溃的Excel，我试图添加error handling，但我已经试图检查，如果工作表存在不工作，仍然崩溃的Excel。

有分离出隐藏模板表的代码，复制它，重新命名新的表，然后重新隐藏模板。

我想要做的是从TextBox5检查input的工作表名称，并检查工作表是否存在，如果显示一个消息框，表示工作表已经存在，如果工作表不存在，则继续执行代码像平常一样。

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

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 

 Sheets("Template").Visible = True ws.Copy before:=Sheets("Details"): Set newws = ActiveSheet: newws.name = newname Sheets("Template").Visible = False 

 With ActiveWorkbook.Sheets("Payment Form").Activate For Each cell In Columns(1).Range("A18:A34").Cells If Len(cell) = 0 Then cell.Select: Exit For Next cell ActiveCell.Value = newname & " " & "-" & name2 & ":" & " " & myCCName End With With ActiveWorkbook.Sheets(newname).Activate ActiveWorkbook.Sheets(newname).Range("D4") = Sheets("Payment Form").Range("a18:a34").End(xlDown).Value ActiveWorkbook.Sheets(newname).Range("D6") = Sheets("Payment Form").Range("L11").Value ActiveWorkbook.Sheets(newname).Range("D8") = Sheets("Payment Form").Range("C9").Value ActiveWorkbook.Sheets(newname).Range("D10") = Sheets("Payment Form").Range("C11").Value End With ActiveWorkbook.Sheets("Payment Form").Activate With ActiveWorkbook.Sheets("Payment Form") Range("J" & lastRow2 + 1) = 0 Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & "" Range("N" & lastRow2 + 1).Formula = "='" & newname & "'!L20" Range("U" & lastRow + 1) = newname & ":" & " " Range("V" & lastRow + 1).Formula = "='" & newname & "'!I21" Range("W" & lastRow + 1).Formula = "='" & newname & "'!L23" Range("X" & lastRow + 1).Formula = "='" & newname & "'!K21" End With answer = MsgBox("Would you like to create another sheet?", vbYesNo + vbQuestion, "New Sheet") If answer = vbYes Then Else Unload Me End If With Application .ScreenUpdating = True .EnableEvents = True .CutCopyMode = True End With Me.TextBox4.Value = "" Me.TextBox5.Value = "" End Sub 

Answer 1

整个代码中的“With”语句似乎有一些常见的拼写错误和一些错误。 我希望能整理起来，logging下这个function，但是由于没有经过testing，我不能保证它能起作用。

我还包括工作表检查function作为一个单独的function

 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 

Answer 2

我个人使用下面的函数来检查工作簿中是否存在一个工作表，在这种情况下它将返回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 

我似乎无法find代码的原始来源，但我不能相信，它是在SO，ozgrid或Mrexcel上find的一些代码的修改版本

编辑：

仔细看看你的代码，似乎你已经在xstvariables中检查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