Sub ListTempl()
Dim lr As Long, i As Long
Dim shname As String
Dim SH As Worksheet
Dim RNG As Range
Dim SHT As Worksheet
Set SHT = Worksheets("Ìîíèòîðèíã")
lr = SHT.Cells(Rows.Count, 2).End(xlUp).Row
Set RNG = SHT.Range(Cells(2, 2), Cells(lr, 2))
For i = 3 To lr
On Error Resume Next
shname = SHT.Cells(i, 2)
Set wsSh = Worksheets(shname)
If Err.Number <> 0 Then
RNG.AutoFilter Field:=2, Criteria1:=shname
SHT.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
    .Range("A1").PasteSpecial xlPasteColumnWidths
    .Range("A1").PasteSpecial xlPasteFormats
    .Range("A1").PasteSpecial xlPasteValues
    .Name = shname
    .Range("A1").Select
End With
    SHT.Activate
    SHT.ShowAllData
End If
    On Error GoTo 0
Next i
End Sub