Private Sub ИмяПодраздела_Change()

With ActiveSheet.ListObjects(Range("A" & fcell.Row).Value)

'..........................................
For Each iSh In ThisWorkbook.Worksheets
  If iSh.Name <> "000" Then
    With iSh
      For Each iCell In .UsedRange.Cells
        If iCell Like "*.*.*.*" Then
          iClmn = iCell.Column
          Exit For
        End If
      Next
      arr = .Range(.Cells(1, iClmn), .Cells(.Cells(.Rows.Count, iClmn).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Value
'...........далее по тексту кода ............

With Worksheets("000")
  For Each iCell In .UsedRange.Cells
    If iCell Like "*.*.*.*" Then
      iClmn = iCell.Column
      Exit For
    End If
  Next
  arr = .Range(.Cells(5, iClmn), .Cells(.Cells(.Rows.Count, iClmn).End(xlUp).Row, iClmn + 1)).Value
  For I = LBound(arr, 1) To UBound(arr, 1)
    If iDic.Exists(arr(I, 1)) Then
      arr(I, 2) = iDic(arr(I, 1))
    End If
  Next
  .Cells(5, iClmn + 1).Resize(UBound(arr, 1)) = Application.Index(arr, 0, 2)
End With

Sub DateFilter()
Dim iCell As Range
Dim rDate As Range
Dim rDel As Range
Dim iDays, I&
iDays = InputBox("Количество дней:", , "90")
If iDays = "" Then Exit Sub
Application.ScreenUpdating = False
With Worksheets("Лист1")
  Set rDate = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
End With
For Each iCell In rDate
  If iCell.Value + Val(iDays) < Now Then
    If Not rDel Is Nothing Then
      Set rDel = Union(rDel, iCell)
    Else
      Set rDel = iCell
    End If
    I = I + 1
  End If
Next
If Not rDel Is Nothing Then
  rDel.EntireRow.Delete
  MsgBox "Удалено " & I & " строк"
End If
Application.ScreenUpdating = True
End Sub

For I = 1 To UBound(M, 1)

Private Sub ИмяРаздела_DropButtonClick()
    Dim ws As Worksheet
    Me.ИмяРаздела.Clear
    For Each ws In Worksheets
        If ws.Range("C1") = Me.Name Then ИмяРаздела.AddItem ws.Name  'Заполнение Combobox "ИмяРаздела" именами вкладок
    Next
End Sub

Private Sub UserForm_Activate()
    Dim ws As Worksheet
    Me.ИмяРаздела.Clear
    For Each ws In Worksheets
        If ws.Range("C1") = Me.Name Then ИмяРаздела.AddItem ws.Name  'Заполнение Combobox "ИмяРаздела" именами вкладок
    Next
End Sub

Sub DelPictures()
Dim iPict As Shape
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each iPict In ActiveSheet.Shapes
  iPict.Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub