Sub Create_sheets()
        
' Объявляем переменные
    Dim collection As New collection
    Dim ws As Worksheet
    Dim new_ws As Worksheet
    Dim last_row As Long
    Dim i As Long
    Dim cell As Range
    Dim Sheet_exists As Boolean
    
' Отключаем лишнее
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
' Задаём ссылку на 1ый лист
    Set ws = ActiveWorkbook.Sheets(1)
    
' Определяем последнюю заполненную ячейку
    last_row = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
' Проходимся по каждой ячейке 1го листа с A2 вниз и добавляем в коллекцию
    For Each cell In ws.Range("A2:A" & last_row)
        
        collection.Add (cell)
        
    Next cell
    

' Создаём новый лист по названию элемента в коллекции (если такого листа ещё нет)
    For i = 1 To collection.Count
        
        Sheet_exists = False
        
        ' Проверяем существует ли лист с таким названием
        For Each ws In ActiveWorkbook.Worksheets
            
            If ws.Name = collection.Item(i) Then
                
                Sheet_exists = True
                
                Exit For
                
            End If
            
        Next ws
        
        ' Если лист не существует, то создаём его
            
            If Not Sheet_exists Then
                
                On Error Resume Next ' На случай если имя листа некорректное
        
        Set new_ws = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
        new_ws.Name = collection.Item(i)
                
                On Error GoTo 0
                
            End If
            
    Next i
    
    
' Очищаем коллекцию
    Set collection = Nothing
    
' Переходим на 1ый лист
    ActiveWorkbook.Sheets(1).Activate
    
' Включаем то, что ранее отключали
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
        
End Sub