Sub Start()
    Range("B1").Select
    Application.Goto Reference:="R4C1:R7002C1"
    Selection.ClearContents
    Call OpenFile
End Sub

Sub OpenFile()
  Dim wApp As Object, wDoc As Object, f$
    f = Application.GetOpenFilename("Документ Microsoft Word, *.doc,Все файлы, *.*")
    If f = "" Then Exit Sub
    Set wApp = CreateObject("Word.Application")
        wApp.Visible = True ' если требуется отобразить
    Set wDoc = wApp.Documents.Add(f)    ' Добавление документа, выбранный файл используется в качестве шаблона
    t = wDoc.Content.Copy
    Set ns = ActiveSheet
    ns.Paste Destination:=ns.Cells(2, 1)
    wApp.Quit (False) ' закрытие Word'а
    Set wApp = Nothing
    Application.Wait (Now + TimeValue("00:00:02"))
    Call RefreshAll
End Sub

Sub RefreshAll()
    '
    ' ОбновитьФорматировать
    
     
    ' ОБНОВИТЬ ВСЕ ЗАПРОСЫ
    Dim IsBG_Refresh As Boolean, oc
    For Each oc In ThisWorkbook.Connections        'запоминаем значение обновления в фоне для запроса
        IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
        'выставляем принудительно ждать завершения запроса
        oc.OLEDBConnection.BackgroundQuery = False
        'обновляем запрос
        oc.refresh
        'возвращаем обновление в фоне в первоначальное состояние
        oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
    Next
    Call MySaveName
End Sub

Sub MySaveName()
    Worksheets("RESULT").Copy
    'there is now a new active workbook
    With ActiveWorkbook
        'save it
        .SaveAs Filename:="\\Mac\Home\Desktop\last docs\Docs\Work\Work form HDD - 15.12.2008\Docs CRYPT\BRP - 2010\Spare Parts\AIR\Compilation\" & Range("p2").Value & ".xlsx", FileFormat:=xlWorkbookDefault
        'optionally close it
        .Close savechanges:=False
    End With
    Call ClearAll
End Sub

Sub ClearAll()
    Range("B1").Select
    Application.Goto Reference:="R4C1:R7002C1"
    Selection.ClearContents
End Sub

Sub Start()
    Range("B1").Select
    Application.Goto Reference:="R4C1:R7002C1"
    Selection.ClearContents
    Call OpenFile
End Sub

Sub OpenFile()
  Dim wApp As Object, wDoc As Object, f$
    f = Application.GetOpenFilename("Microsoft Word, *.doc,Âñå ôàéëû, *.*")
    If f = "" Then Exit Sub
    Set wApp = CreateObject("Word.Application")
        wApp.Visible = True ' 
    Set wDoc = wApp.Documents.Add(f)    ' 
    t = wDoc.Content.Copy
    Set ns = ActiveSheet
    ns.Paste Destination:=ns.Cells(2, 1)
    wApp.Quit (False) ' 
    Set wApp = Nothing
    Application.Wait (Now + TimeValue("00:00:02"))
    Call RefreshAll
End Sub

Sub RefreshAll()
    '
    Dim IsBG_Refresh As Boolean, oc
    For Each oc In ThisWorkbook.Connections        '
        IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
        '
        oc.OLEDBConnection.BackgroundQuery = False
        '
        oc.refresh
        '
        oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
    Next
    Call MySaveName
End Sub

Sub MySaveName()
    Worksheets("RESULT").Copy
    'there is now a new active workbook
    With ActiveWorkbook
        'save it
        .SaveAs Filename:="\\Mac\Home\Desktop\last docs\Docs\Work\Work form HDD - 15.12.2008\Docs CRYPT\BRP - 2010\Spare Parts\AIR\Compilation\" & Range("o2").Value & ".xlsx", FileFormat:=xlWorkbookDefault
        'optionally close it
        .Close savechanges:=False
    End With
    Call ClearAll
End Sub

Sub ClearAll()
    Range("B1").Select
    Application.Goto Reference:="R4C1:R7002C1"
    Selection.ClearContents
End Sub

Sub SaveAS ()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\1.txt", 21, local:=-1
Dim s$
Open "c:\temp\1.txt" For Input As #1
Open "c:\temp\1.txt" For Output As #2
Line Input #1, s
Do Until EOF(1)
   Line Input #1, s
   Print #2, s
Loop
Reset
End Sub