y = Workbooks (tb). Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Private Sub zapolnit()
    nm = TEST.DOC
    gd = ActiveWorkbook.Sheets(1).Range("A1")
    pr = ActiveWorkbook.Sheets(1).Range("B1")

    Set objWord = CreateObject("word.application")
    objWord.Visible = True
    Set objDoc = objWord.Documents.Open(ActiveWorkbook.Path & nm)
    
    Call telo
    
    objDoc.SaveAs2 Filename:=ActiveWorkbook.Path & "\Rezult\" & Left(nm, 5) & "_" & Format(gd, "00") & Format(pr, "00") & ".docx"
    objWord.Quit
End Sub
Private Sub telo()

For bMi = 1 To objDoc.Bookmarks.Count
        If (Len(objDoc.Bookmarks(bMi).Name) - Len(Replace(objDoc.Bookmarks(bMi).Name, "_", ""))) <> 4 Then GoTo NxtBM
        tmpBM = Split(objDoc.Bookmarks(bMi).Name, "_")
        If IsSh(tmpBM(LBound(tmpBM)) & "") = False Then GoTo NxtBM
        Set sh1 = ThisWorkbook.Sheets(tmpBM(LBound(tmpBM)) & "")
        rOw1 = Val(tmpBM(LBound(tmpBM) + 1))
        rOw2 = Val(tmpBM(LBound(tmpBM) + 2))
        cOl1 = Val(tmpBM(LBound(tmpBM) + 3))
        cOl2 = Val(tmpBM(LBound(tmpBM) + 4))
        objDoc.Bookmarks(bMi).Range.Select
        For i = rOw1 To rOw2
            Set r = objWord.Selection.Range
            For j = cOl1 To cOl2
                If Len(sh1.Cells(i, j).Value) = 0 Then
                    objWord.Selection.TypeText Text:="0"
                Else
                    If sh1.Cells(i, j).Value = 0 Then
                        objWord.Selection.TypeText Text:=" "
                    Else
                        objWord.Selection.TypeText Text:=CStr(sh1.Cells(i, j).Value)
                    End If
                End If
                If j <> cOl2 Then objWord.Selection.MoveRight unit:=wdCell
            Next j
            r.Select
            If i <> rOw2 Then objWord.Selection.MoveDown 'unit:=wdCell
        Next i

NxtBM:
    Next bMi
For bMi = 1 To objDoc.Bookmarks.Count
        If (Len(objDoc.Bookmarks(bMi).Name) - Len(Replace(objDoc.Bookmarks(bMi).Name, "_", ""))) <> 1 Then GoTo NxtgBM
        tmpBM = Split(objDoc.Bookmarks(bMi).Name, "_")
            If Mid(tmpBM(0), 1, 3) = "god" Then
                If tmpBM(0) = "god1" Then
                    objDoc.Bookmarks(bMi).Range.Select
                    objWord.Selection = Mid(Format(gd, "00"), 1, 1)
                        GoTo NxtgBM
                Else: objDoc.Bookmarks(bMi).Range.Select
                    objWord.Selection = Mid(Format(gd, "00"), 2, 2)
                        GoTo NxtgBM
                End If
            ElseIf Mid(tmpBM(0), 1, 3) = "mon" Then
                If tmpBM(0) = "mon1" Then
                    objDoc.Bookmarks(bMi).Range.Select
                    objWord.Selection = Mid(Format(pr, "00"), 1, 1)
                        GoTo NxtgBM
                Else: objDoc.Bookmarks(bMi).Range.Select
                    objWord.Selection = Mid(Format(pr, "00"), 2, 2)
                        GoTo NxtgBM
                End If
            End If
            
                        
NxtgBM:
    Next bMi
End Sub
Function IsSh(shN As String) As Boolean
Dim tmpobj As Worksheet
IsSh = False
On Error GoTo FIN
Set tmpobj = ThisWorkbook.Sheets(shN)
IsSh = True
FIN:
End Function

Dim FileN$
FileN = ThisWorkbook.Path & "\" & "Result.xls"
ThisWorkbook.sheets(1).Copy
ActiveWorkbook.SaveCopyAs FileN
ActiveWorkbook.close SaveChanges:=False

Sub probel()
With range ("A1:Z204" & Cells(Rows.Count, 1).end (xlup).row)
.value=application.trim(application.clean(.value))
End with 
End sub

Option Explicit

Sub Otbor()
    Dim a, i&, lRow, kk, rngFiltr As Range, wb As Workbook, sh As Worksheet
    Application.ScreenUpdating = False

    Set wb = Workbooks.Add(1)
    Set sh = wb.Sheets(1)
    ThisWorkbook.Sheets("точки").Activate

    With Sheets("точки")
        lRow = .Range("D" & .Rows.Count).End(xlUp).Row
        a = .Range(.Range("D1"), .Range("D" & lRow)).Value
    End With

    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            .Item(a(i, 1)) = 0&
        Next

        Set rngFiltr = Sheets("точки").Range("A1:K" & lRow)

        If Not Sheets("точки").AutoFilterMode Then rngFiltr.AutoFilter
        For Each kk In .keys
            sh.Cells.Clear
            rngFiltr.AutoFilter Field:=4, Criteria1:=kk
            Sheets("точки").Range("A1:K" & lRow).SpecialCells(xlCellTypeVisible).Copy sh.Cells(1, 1)
            Application.StatusBar = "Сохраняю файл " & kk
            wb.SaveAs ThisWorkbook.Path & "\" & kk
        Next
    End With

    wb.Close 0

    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
End Sub

Application.Dialogs(xldialogSaveAs).Show