复制工作表

Option Explicit

Sub DuplicateWorksheet()
    
    ' Define constants.
    Const PROC_TITLE As String = "Duplicate Worksheet"
    Const IB_PROMPT As String = "Enter the name for the duplicate worksheet"
    Const CLEAR_RANGE As String = "K2,J3,B18:B38,H18:H38,I18:I38,J18:J38,F44"
    
    ' Input the destination worksheet name.
    Dim NewName As String: NewName = InputBox(IB_PROMPT, PROC_TITLE)
    
    ' Check if no entry or the dialog was canceled.
    If Len(NewName) = 0 Then
        MsgBox "No name entered.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Reference the source worksheet and the workbook.
    Dim sws As Worksheet: Set sws = ActiveSheet
    Dim wb As Workbook: Set wb = sws.Parent
    
    Application.ScreenUpdating = False
    
    ' Copy the source and reference this copy, the destination worksheet.
    sws.Copy After:=wb.Sheets(wb.Sheets.Count) ' after last sheet
    Dim dws As Worksheet: Set dws = wb.Sheets(wb.Sheets.Count) ' last sheet
    
    Dim ErrNum As Long
    
    ' Attempt to rename the destination worksheet.
    On Error Resume Next ' prevent several possible errors
        dws.Name = NewName
        ErrNum = Err.Number
    On Error GoTo 0
    
    ' Check if the rename was successful.
    If ErrNum <> 0 Then ' could not rename
        Application.DisplayAlerts = False
            dws.Delete
        Application.DisplayAlerts = True
        MsgBox "Could not rename to '" & NewName & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    'Else ' could rename; do nothing (continue)
    End If
    
    ' Clear.
    dws.Range(CLEAR_RANGE).ClearContents
               
    ' Save!?
    'wb.Save
               
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "The name of the duplicated worksheet is '" & NewName & "'.", _
        vbInformation, PROC_TITLE
  
End Sub

您可以从宏中调用另一个宏。在CopySheetAndRename宏中，如果编写Call ClearData或甚至只编写ClearData（因为VBA可以自己计算出Call部分），VBA将在CopySheetAndRename宏中运行ClearData。

Public Sub CopySheetAndRename()
  Dim newName As String

  On Error Resume Next
  newName = InputBox("Enter the name for the copied worksheet")

  If newName <> "" Then
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = newName
    ClearData
  End If
  
End Sub

我对你的代码的建议是不要使用ActiveSheet。随着你的代码变得越来越复杂，特别是当你在执行过程中创建或更改工作表时，ActiveSheet将很难跟踪，并可能最终给你带来问题。根据我的经验，一些东西最终会在错误的工作表上运行并损坏所有数据。
在ClearData中添加一个Worksheet参数，这样你就可以确定你没有在错误的工作表上运行它。并且在ActiveSheet发生任何变化之前，尽快将新的工作表保存为变量。

Sub ClearData(Target As Worksheet)
  Target.Range("K2,J3,B18:B38,H18:H38,I18:I38,J18:J38,F44").Value = ""
End Sub
Public Sub CopySheetAndRename()
  Dim newName As String

  On Error Resume Next
  newName = InputBox("Enter the name for the copied worksheet")

  If newName <> "" Then
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    Dim ws as Worksheet
    Set ws = Worksheets(Worksheets.Count)
    On Error Resume Next
    ws.Name = newName
    ClearData ws
  End If
  
End Sub