Excel VBA复制ABACUS工作表后按C1日期重命名标签失效问题

问题情况 #

想要通过VBA复制名为「ABACUS」的工作表，将新工作表命名为「W.E.//」格式（日期取自ABACUS工作表的C1单元格，按/**/**格式展示），但运行现有代码后，新工作表被自动命名为「ABACUS(2)」，完全不符合预期格式。

错误原因分析 #

1. 复制目标错误：代码中用ActiveSheet.Copy复制工作表，但此时的ActiveSheet不一定是「ABACUS」，导致复制的不是目标工作表，自然命名逻辑失效。
2. 未指定数据源工作表：命名新表时Range("C1").Value没有明确指定是「ABACUS」的C1单元格，默认读取的是新复制工作表的C1值（为空），无法生成正确名称。
3. 冗余代码干扰：ws.Name = Format(CDate(ws.Range("B2").Value), "DD.MM.YY")这段代码是循环遍历工作表时的逻辑，和新表命名无关，且On Error Resume Next会掩盖命名时的错误，导致问题无法被及时发现。

修正方案 #

1. 明确指定复制「ABACUS」工作表，避免依赖ActiveSheet的不确定性。
2. 将新复制的工作表赋值给变量，方便后续操作。
3. 读取「ABACUS」的C1单元格日期，格式化后拼接成符合要求的表名。
4. 移除无关的冗余代码，取消错误屏蔽以排查潜在问题。

完整修正代码 #

Public Sub CopySheetAndRenamePredefined()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim response As String
    
    ' 原有的输入日期逻辑保留
    For Each ws In Sheets
        If ws.Range("B2") <> "" And ws.Range("C2") = "" Then
            Do
                response = InputBox("Input date in format **/**/**")
                If response <> "" Then
                    ws.Range("C2") = response
                    Exit Do
                ElseIf response = "" Then
                    MsgBox ("You must enter date in format **/**/**")
                Else
                    Exit Do
                End If
            Loop
        End If
    Next ws
    
    Dim WKend
    Dim arr As Variant
    Dim writerow As Long
    
    ' 原有的加班数据复制逻辑保留
    'copy overtime sunday
    With Sheets("ABACUS")
        WKend = .Range("M2").Value2
        arr = .Range("AI21:AI33").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A2") = Format(Date, "dd/mm/yy")
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With
   
    'copy overtime monday
    With Sheets("ABACUS")
        WKend = .Range("AC2").Value2
        arr = .Range("AK21:AK32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With

    'copy overtime tuesday
    With Sheets("ABACUS")
        WKend = .Range("AS2").Value2
        arr = .Range("AM21:AM32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With

    'copy overtime wednesday
    With Sheets("ABACUS")
        WKend = .Range("BI2").Value2
        arr = .Range("AO21:AO32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With

    'copy overtime thursday
    With Sheets("ABACUS")
        WKend = .Range("BY2").Value2
        arr = .Range("AQ21:AQ32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With

    'copy overtime friday
    With Sheets("ABACUS")
        WKend = .Range("CO2").Value2
        arr = .Range("AS21:AS32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With

    'copy  overtime saturday
    With Sheets("ABACUS")
        WKend = .Range("DE2").Value2
        arr = .Range("AU21:AU32").Value
    End With
    With Sheets("OVERTIME")
        writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & writerow) = WKend
        .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    End With
   
    ' --- 修正后的复制与命名逻辑 ---
    Dim newWs As Worksheet
    ' 明确复制ABACUS工作表到OVERTIME之后
    Sheets("ABACUS").Copy After:=Worksheets("OVERTIME")
    ' 将新复制的工作表赋值给变量
    Set newWs = ActiveSheet
    
    ' 获取ABACUS的C1日期，格式化后命名新表
    Dim targetDate As String
    ' 确保C1是日期格式，转换后按指定格式输出
    targetDate = Format(CDate(Sheets("ABACUS").Range("C1").Value), "dd/mm/yyyy")
    ' 设置新表名称
    newWs.Name = "W.E." & targetDate
    
    ' 后续清理逻辑保留
    newWs.Shapes("Button 2").Delete
    Worksheets("ABACUS").Activate
    Range("D5:DK17").ClearContents
    Range("C2").ClearContents
    Range("BP22:CE33").ClearContents
    Range("E3,G3,I3,K3,M3,O3,Q3,S3,U3,W3,Y3,AA3,AC3,AE3,AG3,AI3,AK3,AM3,AO3,AQ3,AS3,AU3,AW3,AY3,BA3,BC3,BE3,BG3,BI3,BK3,BM3,BO3").ClearContents
    Range("BQ3,BS3,BU3,BW3,BY3,CA3,CC3,CE3,CG3,CI3,CK3,CM3,CO3,CQ3,CS3,CU3,CW3,CY3,DA3,DC3,DE3,DG3,DI3,DK3").ClearContents
    [B25] = Range("DM2").Value
    [B26] = Range("DM2").Value
    [B27] = Range("DM2").Value
    [B28] = Range("DM2").Value
    [B29] = Range("DM2").Value
    [B30] = Range("DM2").Value
    [B31] = Range("DM2").Value
    [B32] = Range("DM2").Value
    
    Application.ScreenUpdating = True
End Sub

额外说明 #

• 如果ABACUS的C1单元格不是标准日期格式，可能需要先做格式校验，避免CDate转换出错，可以添加错误处理逻辑。
• 移除了原代码中On Error Resume Next，这样如果命名时出现错误（比如名称重复），会直接抛出提示，方便排查问题。

内容的提问来源于stack exchange，提问作者Ben