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 ÀâòîÏå÷àòü()
'
' ÀâòîÏå÷àòü Ìàêðîñ
'
' Ñî÷åòàíèå êëàâèø: Ctrl+q
'
    
For i = 1 To 2
    
    Range("J2").Select
    ActiveCell.FormulaR1C1 = i
    Range("J2").Select

    ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _
        :=True, IgnorePrintAreas:=False

Next

'    Dim li As Long
'    With Sheets("Ìàêåò")
'        For li = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'            .Range("M2").Value = Cells(li, 1)
'            .Calculate
'            .PrintOut Copies:=1
'        Next li
'    End With

End Sub

Sub aaa()
Dim sh As Worksheet, a&, b&, c&, arr(), aa As Range, x&
a = Sheets("overall").Index: ReDim arr(1 To Sheets.Count - a)
For b = 1 To UBound(arr): arr(b) = a + b: Next: b = 2
For a = arr(1) To arr(UBound(arr))
  Set sh = Sheets(a): c = sh.Cells(.Rows.Count, 2).End(xlUp).Row
  Set aa = sh.Range("B2:V" & "X1" & "Y2" & c): aa.Copy Sheets("overall").Cells(b, 2)
  b = b + aa.Rows.Count: x = x + aa.Rows.Count
Next
ReDim arr(1 To x): For a = 1 To x: arr(a) = a: Next
Sheets("overall").[A2].Resize(x, 1).Value = Application.Transpose(arr)
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