Developing.ru

Добрый день! Сочинил свой первый макрос для копирования заполненного листа «ИСХОДНЫЙ» на лист с названием взятым из ячейки «F1». Работает нормально. Только маленький пустячок мешает – если название повторяется, то макрос не работает. Как организовать проверку листов в книге на уникальность. Листов будет постепенно добавляться до 50. Спасибо.

Sub ZET_001()
'
' ZET_001 Макрос
' копирование номера вагона из ячейки F1
' на новый лист с номером вагона
'
'

Application.ScreenUpdating = False
Dim RD0 As Range
Set RD0 = Range("ИСХОДНЫЙ!F1")
Sheets("ИСХОДНЫЙ").Select
Sheets("ИСХОДНЫЙ").Copy After:=Sheets(1)
' Sheets("ИСХОДНЫЙ (2)").Select
With ActiveWorkbook.Sheets("ИСХОДНЫЙ (2)").Tab
.Color = 6299648
.TintAndShade = 0
End With
Sheets("ИСХОДНЫЙ (2)").Name = RD0
' как удалить лист из книги, если название повторяется
Range("F1").Select
ActiveWorkbook.Save
MsgBox "Лист с номером вагона << " & RD0 & " >> будет создан за листом <<ИСХОДНЫЙ>> и сохранён!"
MsgBox "Листов в данной книге " & Str(Worksheets.Count)
'
End Sub

Здравствуйте goldmine.

Код: Выделить всё

Sub ZET_001()
' ZET_001 Макрос
' копирование номера вагона из ячейки F1
' на новый лист с номером вагона
'
Const stName = "ИСХОДНЫЙ"
Const tit1 = "Лист с номером вагона - "
Const tit2 = "создан за листом <ИСХОДНЫЙ> и сохранён!", tit4 = "Листов в данной книге - "
Dim oSheet As Object, oSheets As Object, sNew As String, i As Integer, s As String
On Error GoTo 9
Application.ScreenUpdating = False
Set oSheet = Sheets(stName)
Set oSheets = ActiveWorkbook.Worksheets
oSheet.Copy After:=Sheets(stName)
s = oSheet.Range("F1")
2
sNew = s & IIf(i > 0, "(" & i & ")", "")
For Each oSheet In oSheets
    If oSheet.Name = sNew Then
        'i = i + 1: GoTo 2 'добавление индекса к имени листа
        'вариант с удалением существующего
        '"как удалить лист из книги, если название повторяется"
        Application.DisplayAlerts = False
        oSheet.Delete:
        Application.DisplayAlerts = True
        Exit For
    End If
Next
 ' подразумевая, что лист stName первый 
With Sheets(2).Tab 
    .Color = 6299648
    '.TintAndShade = 0
End With
Sheets(2).Name = sNew
Range("F1").Select
'ActiveWorkbook.Save
MsgBox tit1 + s + vbCrLf + tit2, vbInformation, tit4 & Worksheets.Count
9
Application.ScreenUpdating = True
End Sub

Евгений.

Спасибо за помощь!

Developing.ru

Удаление листов с одинаковыми названием

Удаление листов с одинаковыми названием

Re: Удаление листов с одинаковыми названием

Re: Удаление листов с одинаковыми названием