Sub iSelectColumnForFilter()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Dim Sht_table As String
Dim iLastCol As Integer
Dim iSelectCol As Integer
Dim iLastRow As Long
Application.ScreenUpdating = False
  Application.DisplayAlerts = False          'îòêëþ÷åíèå ïðåäóïðåæäàþùèõ ñîîáùåíèé
   Sht_table = ActiveSheet.Name
    For Each Sht In ThisWorkbook.Worksheets  'óäàëÿåì âñå ëèñòû, êðîìå Sht_table
      If Sht.Name <> Sht_table Then Sht.Delete
    Next
  Application.DisplayAlerts = True
   iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column  'ïîñëåäíèé ñòîëáåö
  iSelectCol = Application.InputBox("Âûáåðèòå íîìåð ñòîëáöà ôèëüòðàöèè", Type:=1)
  If iSelectCol > iLastCol Then MsgBox "Âûáðàííûé ñòîëáåö âûõîäèò çà äèàïàçîí ñòîëáöîâ": Exit Sub
  Set Sht = ThisWorkbook.Worksheets(Sht_table)
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Columns(iLastCol + 2).ClearContents
    Range(Cells(1, iSelectCol), Cells(iLastRow, iSelectCol)).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Cells(1, iLastCol + 2), Unique:=True
        n = Cells(Rows.Count, iLastCol + 2).End(xlUp).Row
    For i = 2 To n          'öèêë ïî óíèêàëüíûì çíà÷åíèÿì âûáðàííîãî ñòîëáöà
        Criterij = Sht.Cells(i, iLastCol + 2)
        iName = Criterij    'èìÿ íîâîãî ëèñòà
       Sht.Range(Sht.Cells(1, 1), Sht.Cells(iLastRow, iLastCol)).AutoFilter iSelectCol, Criterij
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'äîáàâëÿåò íîâûé ëèñò â êîíåö
          .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteColumnWidths
          .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteFormats
          .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
Application.ScreenUpdating = True
   Sht.Activate
   Columns(iLastCol + 2).ClearContents
End Sub

Sub iTown()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("MH-2019")
        Columns("E").ClearContents
    Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("E3"), Unique:=True
        n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 4 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "E")
        iName = Criterij    'имя нового листа
       Sht.Range("A3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AutoFilter 3, Criterij
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:C1").PasteSpecial xlPasteColumnWidths
          .Range("A1:C1").PasteSpecial xlPasteFormats
          .Range("A1:C1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
Application.ScreenUpdating = True
End Sub

Sub Combine()Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub