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

Sub Синхро()
    Dim A As Double
    Dim B As Double
    Dim i As Long
    Dim bExit As Boolean
     
    Do
     
        A = Range("C1").Value
        B = Range("D1").Value
        
        If A = B Then Exit Sub
        Else
            If A > B Then
                For i = B + 1 To A Step 1
                Макрос1
                Next
            ElseIf A < B Then
                For i = A + 1 To B Step 1
                Очистить
                Next
            Else
                bExit = True
            End If
        bExit = True
        End If
         
        If bExit Then Exit Do
    Loop
End Sub

Sub Синхро()
    Dim A As Double
    Dim B As Double
    Dim i As Long
    Dim bExit As Boolean
     
    Do
        A = Range("C1").Value
        B = Range("D1").Value
     
        If A > B Then
            For i = B + 1 To A Step 1
                Макрос1
            Next
        ElseIf A < B Then
            For i = A + 1 To B Step 1
                Очистить
            Next
        Else
            bExit = True
        End If
         
        If bExit Then Exit Do
    Loop
End Sub