Question

我的工作表名为＆＃34;图1＆＃34;，＆＃34;图2＆＃34;，＆＃34;图3＆＃34;和＆＃34;自定义图表＆＃34;。我想制作一份＆＃34; Custom Chart＆＃34;并命名为＆＃34;自定义1＆＃34;。我想无限期地执行此操作，以便连续的副本被命名为＆＃34;自定义2＆＃34;，＆＃34;自定义3＆＃34;等。我的代码成功制作副本，但未能按预期命名。问题是While-End循环。 VBA拒绝它，因为条件不是布尔值。如何根据我的规则更改此代码以命名新副本？

Sub CustomChartCopy()
'Copy the Custom Chart to a new worksheet to preserve it
'Note: The original data series are preserved, but no longer change with the Custom Chart macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim j As Integer
Dim ws As Worksheet

j = 1

Set CustomChart = Sheets("Custom Chart")

CustomChart.ChartArea.Copy
Sheets.Add After:=Sheets(Sheets.Count)

With ActiveSheet
    .Paste
    .ChartObjects("Chart 1").Activate
End With

ActiveChart.Location Where:=xlLocationAsNewSheet

'delete the blank last sheet of the workbook
With ActiveWorkbook
    .Worksheets(.Worksheets.Count).Delete
End With

'Name the new chart copy
While Not InStr(ws.name, j)
    ActiveChart.name = "Custom " & j
    j = j + 1
End While

ActiveSheet.Move _
    After:=ActiveWorkbook.Sheets("Custom Chart")

ActiveWindow.zoom = 140

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

最大，

使用Wend

替换End

“---

Answer 2

Sub CustomChartCopy()
'Copy the Custom Chart to a new worksheet to preserve it
'Note: The original data series are preserved, but no longer change with the Custom Chart macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim j As Integer
'Dim ws As Worksheet

Set CustomChart = Sheets("Custom Chart")

CustomChart.ChartArea.Copy
Sheets.Add After:=Sheets(Sheets.Count)

With ActiveSheet
    .Paste
    .ChartObjects("Chart 1").Activate
End With

ActiveChart.Location Where:=xlLocationAsNewSheet

'delete the blank last sheet of the workbook
With ActiveWorkbook
    .Worksheets(.Worksheets.Count).Delete
End With

'move the custom chart copy
ActiveSheet.Move _
    Before:=ActiveWorkbook.Sheets("EIRP LL Archive")

're name the custom chart copy
On Error GoTo Error_Handler
j = 1
Start:
ActiveSheet.name = "Custom" & j
ActiveWindow.zoom = 140
Exit Sub

Error_Handler:
j = j + 1
Resume Start

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

根据现有工作表名称命名新工作表

2 个答案: