Dim Nstroki As Long
Nstroki = Sheets("Фильтр").Cells(Rows.Count, "A").End(xlUp).Row - 5

.FormulaR1C1 = "=ROW(Фильтр!R3C4:R[" & Nstroki & "]C4)"

.FormulaR1C1 = "=ROW(Фильтр!R3C4:R[" & Nstroki & "]C4)"

Range(Cells(5, 1), Cells(Rows.Count, Cells(5, 1).Column).End(xlUp)).Select

Selection.Offset(0, 3).Select

Range(Selection, Selection.Offset(0, 3)).Select

Sub Макрос()
Dim A, B
'Определение адреса ячеек, смещённых вправо от активной:
    A = Range(ActiveCell.Offset(0, 1))
    B = Range(ActiveCell.Offset(0, 2))
    ActiveCell.FormulaR1C1 = "=R[" & B & "]C-R[" & A & "]C"
End Sub

Private Sub q1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
   If ActiveWorkbook.Name = ThisWorkbook.Name And ActiveSheet.Name = Sheet2.Name Then
     If MsgBox("Вы хотите удалить столбец", vbYesNo + vbQuestion) <> vbYes Then
       CancelDefault = True
     End If
   End If
End Sub

Private Sub q2_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
 If ActiveWorkbook.Name = ThisWorkbook.Name And ActiveSheet.Name = Sheet2.Name Then
   If MsgBox("Вы хотите вставить столбец", vbYesNo + vbQuestion) <> vbYes Then
     CancelDefault = True
   End If
 End If
End Sub

Private Sub q1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  With ThisWorkbook.Sheets("Лист1")
   If MsgBox("Вы хотите удалить столбец", vbYesNo + vbQuestion) <> vbYes Then
     CancelDefault = True
   End If
  End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    With Target
        If .Address = .EntireColumn.Address Then
            frmColumnChange.Show
        End If
    End With
End Sub

Sub Макрос1()
    X = Range("AS5" & Cells(Rows.Count, 1).End(xlDown)).Row
    Range("AS3").FormulaR1C1 = "=ROWS(R[2]C:R[" & X & "]C)"
End Sub

Sub Макрос2()
Dim lLastRow As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("AS3").FormulaR1C1 = "=ROWS(R[2]C:R[" & lLastRow & "]C)"
End Sub

'сохранении книги на рабочий стол
ПутьКРабочемуСтолу = CreateObject("WScript.Shell").SpecialFolders("Desktop")
ActiveWorkbook.SaveAs ПутьКРабочемуСтолу & "\" & Replace(ThisWorkbook.Name, ".xlsm", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Private Sub ListBox1_Change()
    Dim arr$(), i%, txt$
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then txt = txt & ListBox1.List(i) & ","
    Next i
    With wbsh
        If txt = "" Then .UsedRange.AutoFilter: Exit Sub
        txt = Left$(txt, Len(txt) - 1)
        arr = Split(txt, ",")
        .UsedRange.Offset(1, 0).AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
    End With
End Sub

With Лист31.Range("$A$2:$A$2355")

.UsedRange.Offset(1, 0).AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues

Private Sub ListBox1_Change()
Application.ScreenUpdating = False
Dim Arr()
Dim Str$, i%, u%
Dim Фильтр, Entry
u = 0
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) Then
        ReDim Preserve Arr(u)
        Arr(u) = ListBox1.List(i, 0)
        u = u + 1
    End If
Next i
With Sheets("Фильтр")
    Фильтр = .Range("a3", .Range("a" & Rows.Count).End(xlUp)).Value
    If u = 0 Then .AutoFilter Field:=1: Exit Sub
    .AutoFilter Field:=1, Criteria1:=Array(Arr), Operator:=xlFilterValues
End With
Application.ScreenUpdating = True
End Sub