Sub AInsert1()
Dim c As Long
Dim lRow As Long
c = 1
lRow = Application.WorksheetFunction.CountA(Columns(c))
  Worksheets("Лист5").Range(Cells(3, 1), Cells(3, 48)).Copy
  Worksheets("Лист5").Range(Cells(lRow + 1, 1), Cells(lRow + 1, 48)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

    Workbooks.Open Filename:= _
        "118-06-20  [Исакова А.В.] .mht"

Sub ManualSaveFile()
   'Обьявляем переменные
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
   
        Application.ScreenUpdating = False 'отключаем обновление экрана
          Application.DisplayAlerts = False ' Отключаем Алерт
           Application.Run "InsertPathName" ' Вставляем путь к файлу в ячейку
              'Получаем сведенья из ячейки
           CellValue = Лист1.Cells(1, 1)
                Path = Left(CellValue, Len(CellValue) - 3)
           'Формируем путь и имя файла
                FinalFileName = Path & "txt"
            ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                              FileFormat:=xlText  'Сохраняем файл, этот файл потом пытаемся открыть в Ворде и Ворд ругается.
            ActiveWorkbook.SaveAs Filename:="C:\Stat\Bionica\Exsport.xlsm", FileFormat _
                :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False ' Этот файл сейчас приходиться сохранять, что бы Ворд не ругался...
          Application.DisplayAlerts = True 'Включаем алерт
        Application.ScreenUpdating = True 'включаем обновление экрана
End Sub

Sub Синхро()
' Синхронизация

   Dim i As Long
   If IsNumeric([C16].Value) Then
       For i = 1 To [C16].Value
           Application.Run "Добавить"
       Next i
   End If
End Sub