Function CheckRtfFilesForTables1(q1)
    Dim arr As Variant
    Dim tmp(1 To 4) As Variant
    Dim data() As Variant
    Dim i As Long, j As Long, k As Long
    Dim filePath As String
    Dim currentFile As String
    Dim wordApp As Object
    Dim doc As Object
    Dim tbl As Object
    Dim strpath As String
    Dim isFileOpen As Boolean
    Dim rData As Variant
    Dim cellData As String
    On Error Resume Next
    arr = q1
    ReDim data(1 To 1)
    strpath = arr(1)
    If Right(Replace(strpath, " ", ""), 1) <> "\" Then strpath = strpath & "\" 
    Set wordApp = CreateObject("Word.Application")
    For i = 2 To UBound(arr)
        currentFile = arr(i)
        filePath = strpath & currentFile     
        isFileOpen = False
        For j = 1 To wordApp.Documents.Count
            If wordApp.Documents(j).FullName = filePath Then
                Set doc = wordApp.Documents(j)
                isFileOpen = True
                Exit For
            End If
        Next j
        If Not isFileOpen Then
            Set doc = wordApp.Documents.Open(filePath, ReadOnly:=True)
        Else
            doc.Activate
        End If   
        For j = 1 To doc.Tables.Count
            Set tbl = doc.Tables(j)
            If Not tbl Is Nothing Then
                tmp(1) = tbl.cell(1, 1).Range.Text  
                tmp(1) = Left(tmp(1), Len(tmp(1)) - 2) 
                tmp(2) = tbl.Columns.Count          
                tmp(3) = tbl.Rows.Count             
                ReDim rData(1 To tmp(3), 1 To tmp(2))
                For k = 1 To tbl.Rows.Count
                    For m = 1 To tbl.Columns.Count
                        rData(k, m) = tbl.cell(k, m).Range.Text
                        rData(k, m) = Left(rData(k, m), Len(rData(k, m)) - 2) 
                        If Val(Replace(rData(k, m), ",", ".")) = rData(k, m) and rData(k, m)<>"" Then rData(k, m) = Val(Replace(rData(k, m), ",", "."))
                    Next m
                Next k
                tmp(4) = rData
                data(UBound(data)) = tmp
                ReDim Preserve data(1 To UBound(data) + 1)  
            End If
        Next j
   ReDim Preserve data(1 To UBound(data) - 1)
        If Not isFileOpen Then
            doc.Close False
        End If
    Next i
    CheckRtfFilesForTables1 = data
    wordApp.Quit
    Set wordApp = Nothing
End Function

            wdApp.Selection.EndKey Unit:=6
            wdApp.Selection.Paste

Sub CopyNamedRangeToWord()
    Dim nm As Name
    Dim rng As Range
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim shp As Object

    ' Создаем новый экземпляр Word
    On Error Resume Next
    Set wdApp = GetObject(Class:="Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add

    For Each nm In ThisWorkbook.Names
        If Left(nm.Name, 1) = "В" Then
            ' Добавляем новый лист, если это не первая вставка
            If wdDoc.Content.End <> 0 Then
                wdDoc.Words.Last.InsertBreak Type:=7 '
            End If
             wdApp.Selection.EndKey Unit:=6 '          
            Set rng = Range(nm.RefersTo)
            rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture         
            ' Вставляем картинку
            wdDoc.Content.Paste
            Set shp = wdDoc.InlineShapes(wdDoc.InlineShapes.Count).ConvertToShape
            
            ' Устанавливаем размер картинки, если нужно
            shp.LockAspectRatio = True
            shp.Width = 400 ' Измените размер по необходимости
            
            ' Добавляем подпись к рисунку
            wdDoc.Content.InsertAfter Text:="Подпись: " & nm.Name & vbCrLf
        End If
    Next nm
    Set shp = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

Private Sub CommandButton1_Click()
Dim i As Integer
For i = 0 To UBound(TxtBx_arr)
   Bmarks(i)(1) = TxtBx_arr(i).Value
   Call Bmarkschange(Bmarks(i)(0), Bmarks(i)(1))
Next i
Application.DisplayAlerts = wdAlertsNone
ActiveDocument.Fields.Update
Application.DisplayAlerts = wdAlertsAll
End Sub

Private Sub Bmarkschange(str1, str2)
Dim bmRng As Range
With ActiveDocument
 On Error Resume Next
 Set bmRng = .Bookmarks(str1).Range
  bmRng.Text = str2
  .Bookmarks.Add str1, bmRng
End With
End Sub

ActiveDocument.Fields.Update