Dim oWord As Object: Set oWord = CreateObject("Word.Application") 'создать Word
     oWord.Visible = True
Dim oDoc As Object: Set oDoc = oWord.Documents.Add 'создать документ Word

    With oDoc.Parent.Selection
        Set myTable = oDoc.Tables.Add(.Range, 4, 3, DefaultTableBehavior, AutoFitBehavior) 'создать таблицу 4 строки 3 столбца
        oDoc.Content.Select 'выделить весь документ
        oDoc.Parent.Selection.Move Unit:=2 'сместиться вконец, тем самым выйти из таблицы
        .TypeText "123123 " & vbNewLine 'писать текст после таблицы
    End With

x= "cells(1,1)"
debug.print Range(x).row

Sub CombineWorkbooks()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets(1) 'вместо 1, можно указать "Лист1" например
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Dim FilesToOpen
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
                  (FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
                   MultiSelect:=True, Title:="Files to Merge")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        GoTo ExitHandler
    End If
    x = 1
    While x <= UBound(FilesToOpen)
        Set wb1 = Workbooks.Open(Filename:=FilesToOpen(x)) 'присвоение на переменную объекта открываемой книги
        For Each ws1 In wb1.Worksheets 'перебор листов в открываемой книге
            i = ws.Cells(Rows.Count, 1).End(xlUp).Row 'последняя строка по 1 столбцу в этой книге
            i1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'последняя строка по 1 столбцу в открываемой книге книге
            If i1 > 1 Then 'если на листе есть чтото кроме шапки
                ws1.Rows("2:" & i1).Copy ws.Cells(i + 1, 1) 'вставить вместе с формулами
            End If
        Next ws1
        x = x + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    IName = Environ("UserName")
    Select Case IName
        Case "Иванов"
            If Not Intersect(Target, Range("A1:A100")) Is Nothing And IsEmpty(Target) Then
                Target.Locked = False
            Else
                Target.Locked = True
            End If
        Case "Петров"
            If Not Intersect(Target, Range("B1:B100")) Is Nothing And IsEmpty(Target) Then 
                Target.Locked = False
            Else
                Target.Locked = True
            End If
    End Select
End Sub

ActiveSheet.Range("$A$1:$A$14").AutoFilter Field:=1, Criteria1:="<>" & "", Operator:=xlAnd, Criteria2:="<>0", Operator:=xlFilterValues

con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 12.0;HDR=No;IMEX=1""")

    Set con = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
        con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 12.0;HDR=No;IMEX=1""")
            
            rst.Open "(Select F3 as ДатаОпер, F2 as ДатаЗап, F4 as Факт, 0 as План FROM [Факт$] WHERE F1 = '" & lc & "')" & _
            "union all (Select t1.ДатаОпер, t1.ДатаЗап, 0 as Факт, t1.План from " & _
            "(Select F1 as ЛС, F3 as Согл, F4 as ДатаОпер, F2 as ДатаЗап, F5 as План FROM [План$] WHERE F6 ='1' and F1 = '" & lc & "') t1 " & _
            "INNER JOIN (Select F1 as ЛС, F3 as Согл, F4 as ДатаОпер, F5 as План, MAX(F2) as ДатаЗап FROM [План$] WHERE F1 = '" & lc & "' GROUP BY F1, F3, F4, F5) t2 " & _
            "ON t1.ЛС=t2.ЛС AND t1.ДатаЗап=t2.ДатаЗап and t1.Согл=t2.Согл and t1.План=t2.План and t1.ДатаОпер=t2.ДатаОпер) " & _
            "order by ДатаОпер Desc", con

            plfa.Cells(2, 1).CopyFromRecordset rst
        rst.Close
        con.Close

Function SumAllList(r As Range) As Currency
Application.Volatile
Dim ws As Worksheet
SumAllList = 0
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Общее сальдо" Then
            SumAllList = SumAllList + ws.Cells(r.Row, r.Column)
        End If
    Next ws
End Function