我正在使用下面的代码，复制隐藏的工作表并将其复制，重命名并在两张纸上填写某些字段。
我这样做了，因为我需要复制隐藏工作表的布局和格式。
我遇到的问题是，当我点击创建按钮时，如果工作表已经退出，它会完全崩溃Excel，我试图添加错误处理但是我试图检查工作表是否存在的所有内容都没有＃39 ;工作仍然崩溃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
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
答案 0 :(得分：1)
在整个代码中，“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
答案 1 :(得分：0)
我个人使用下面的函数来检查工作簿中是否已经存在工作表，在这种情况下它返回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
我似乎无法找到代码的原始来源，但我不能相信，它是我在SO，ozgrid或Mrexcel上找到的某些代码的修改版本
编辑：
仔细看看你的代码，似乎你已经检查了xst变量中是否存在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