Sub Tablica262()
Dim i As Long
Dim iLastRow As Long
Dim iData As Date
Dim Nomer As Long
Dim NomerList As Integer
Dim iMonth As String
Dim iYear As Long
Dim FoundMonth As Range
Dim FoundYear As Range
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
   With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{1,2}\.\d{4}(?=г.)"
        iData = "01." & .Execute(Cells(i, "B"))(0)
        iMonth = UCase(Format(iData, "MMMM"))
        iYear = WorksheetFunction.Text(iData, "YYYY")
     .Pattern = "(\d{6}) от\s{1,4}(\d{1,2}\.\d{1,2}\.\d{4})$"
        Nomer = .Execute(Cells(i, "B"))(0).SubMatches(0)
        iData = .Execute(Cells(i, "B"))(0).SubMatches(1)
     .Pattern = "\d{1,3}"
       NomerList = .Execute(Cells(i, "E"))(0)
   End With
   With Worksheets("Лист" & NomerList)
     Set FoundMonth = .Rows(10).Find(iMonth, , xlValues, xlWhole)
     Set FoundYear = .Columns(1).Find(iYear, , xlValues, xlWhole)
     .Cells(FoundYear.Row, FoundMonth.Column) = Nomer
     .Cells(FoundYear.Row + 1, FoundMonth.Column) = iData
     .Range("A2") = Cells(i, "E")
   End With
  Next
End Sub