Как перебрать все и заменить некоторые листы в книге Excel

Question

Я пишу макрос в VBA для Excel. Я хочу, чтобы он заменил все листы, за исключением нескольких. Сначала есть цикл, который удаляет нежелательные листы, а затем приходит еще один, который создает новые листы, чтобы их отменить! При первом запуске макрос удаляет нежелательные листы. Однако, если он снова запущен, кажется, что он не может удалить ранее созданные листы, что вызывает ошибку двукратного имени.

(Переменная rng должна распространяться на всю строку, но я еще не исправил ее.) Надеюсь, вы, ребята, можете дать некоторое представление, высоко ценимое!

sub Terminator() 
Dim Current As Worksheet 
Application.DisplayAlerts = False 
' Loop through all of the worksheets in the active workbook. 
For Each Current In Worksheets 
    If Not Current.Name = "Data" Then 
     Worksheets(Current.Name).Delete 
    End If 
Next Current 
Application.DisplayAlerts = True 

' Define range for loop 
Dim rng As Range, cell As Range 
Set rng = Sheets("Data").Range("A5:M5") 
' Loop through entire row, looking for employees 
For Each cell In rng 
    If cell.Value = "Nummer" Then 
     ' Make new chart for employee 
     With Charts.Add 
      .ChartType = xlLineMarkers 
      .Name = cell.Offset(-1, 1).Value 
      .HasTitle = True 
      .ChartTitle.Text = cell.Offset(-1, 1).Value 
      ' Set data (dynamic) and x-axis (static) for new chart 
      .SetSourceData Source:=Sheets("Data").Range(cell.Offset(-2, 3), cell.Offset(7, 4)) 
      .Axes(xlValue).MajorGridlines.Select 
      .FullSeriesCollection(1).XValues = "=Data!E4:E12" 
      ' Add trendlines 
      .FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _ 
      :=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _ 
      "Trend (DDE)" 
      .FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _ 
      :=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _ 
      "Trend (SDE)" 
     End With 
     ' Chart is moved to end of all sheets 
     Sheets(cell.Offset(-1, 1).Value).Move _ 
     after:=Sheets(Sheets.Count) 
    End If 
Next cell 
End Sub 

Answer 1

Нет необходимости определять рабочий лист с Worksheets()

Sub Terminator() 
Dim Current As Worksheet 
Application.DisplayAlerts = False 
' Loop through all of the worksheets in the active workbook. 
For Each Current In ActiveWorkbook.Worksheets 
    If Not Current.Name = "Data" Then 
     Current.Delete 
    End If 
Next Current 
Application.DisplayAlerts = True 
End sub 

Answer 2

Следующий код (незначительные изменения работали в моей книге), вы уверены, что у вас есть имена, занесенные в Если в вашей книге? Во всяком случае, я думаю, что лучше использовать Выберите для нескольких возможных соответствующих двух

Sub Terminator() 

    Dim Current       As Excel.Worksheet 

    Application.DisplayAlerts = False 

    ' Loop through all of the worksheets in the active workbook. 
    For Each Current In ActiveWorkbook.Sheets 
     If Not (Current.Name = "Data") Then 
      ActiveWorkbook.Worksheets(Current.Name).Delete 
     End If 
    Next Current 
    Application.DisplayAlerts = True 

End Sub 

Answer 3

Решения об исключении поставляются РГ, но в случае, если вы хотите избежать некоторых и заявлений для каждого листа, который вы хотите сохранить , вы можете использовать функцию, аналогичную приведенной ниже isInArray:

Sub Terminator() 

Dim Current As Variant 

Application.DisplayAlerts = False 
' Loop through all of the worksheets in the active workbook. 
For Each Current In ThisWorkbook.Sheets 
    If Not isInArray(Current.Name, Array("Data")) Then 
     Current.Delete 
    End If 
Next 
Application.DisplayAlerts = True 
End Sub 

Function isInArray(theValue As String, vArr As Variant) As Boolean 
    Dim vVal As Variant 

    isInArray = False 
    For Each vVal In vArr 
     If LCase(vVal) = LCase(theValue) Then 
      isInArray = True 
     End If 
    Next 

End Function 

EDIT: функцию, которая принимает имя листа в качестве аргумента, и возвращает объект рабочего листа этого имени. Если имя уже сделано, существующий лист удаляется и создается новый:

'example of use: 
'set newWorksheet = doExist("This new Sheet") 

Function doExist(strSheetName) As Worksheet 
    Dim wb As Workbook: Set wb = ThisWorkbook 
    Dim wsTest As Worksheet 
    Dim nWs As Worksheet 

    Set wsTest = Nothing 
    On Error Resume Next 
    'Set wsTest = wb.Worksheets(strSheetName) 'commented out in Edit of Edit 
    Set wsTest = wb.Sheets(strSheetName) 'as a comment for one of the other threads reveal, the error could be the deletion of Worksheets, which would be a subgroup to Sheets of which graph sheets are no a part 
    On Error GoTo 0 

    If Not wsTest Is Nothing Then 
     Application.DisplayAlerts = False 
     wsTest.Delete 
     Application.DisplayAlerts = True 
    End If 

    'Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) 'Edit of Edit, the later call to Charts.Add does this for you 
    'doExist.Name = strSheetName 'Edit of Edit, no need to return anything 

End Function