Sub Create1()
    
    Dim sh1 As Worksheet, sh2 As Worksheet, sh As Worksheet
    Dim lr As Long, i As Integer, r As Long

    Application.ScreenUpdating = False
    Set sh1 = Worksheets("Лист1")
    Set sh2 = Worksheets("Лист2")
    
    lr = 2
    Do While sh2.Cells(lr, "C").Value <> ""
        lr = lr + 1
    Loop
    lr = lr - 1
    
    On Error Resume Next
    For i = 2 To lr
        r = 0
        r = WorksheetFunction.Match(sh2.Cells(i, "B").Value, sh1.Columns("E"), 0)
        If r <> 0 Then
            Set sh = Nothing
            Set sh = Worksheets(sh2.Cells(i, "C").Value)
            If sh Is Nothing Then
                Worksheets.Add After:=Sheets(Sheets.Count)
                ActiveSheet.Name = sh2.Cells(i, "C").Value
            End If
        End If
    Next i
    On Error GoTo 0
    sh1.Activate
    Application.ScreenUpdating = True
    
End Sub