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

Public Sub tojsonbeauty()
    savename = "exportedxls.json"
    myFile = Application.DefaultFilePath & "\" & savename
    Open myFile For Output As #1
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    lcolumn = wks.Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
    Dim titles() As String
    ReDim titles(lcolumn)
    For i = 1 To lcolumn
        titles(i) = wks.Cells(1, i)
    Next i
    Print #1, "["
    dq = """"
    For j = 2 To lrow
      Print #1, "{"
       For i = 1 To lcolumn
         cellvalue = wks.Cells(j, i)
           If i = 1 Then
            Print #1, dq & titles(i) & dq & ":" & dq & cellvalue & dq
            Else
             Print #1, dq & "characteristics" & dq & ":" & "{"
 
            Print #1, dq & titles(i) & dq & ":" & dq & cellvalue & dq
             Print #1, "}"
           End If
           If i <> lcolumn Then
               Print #1, ","
           End If
       Next i
       Print #1, "}"
       If j <> lrow Then
           Print #1, ","
       End If
    Next j
    Print #1, "]"
    Close #1
    a = MsgBox("Saved as " & savename, vbOKOnly)
End Sub

Public Sub subitem()
savename = "exportedxls.json"
Dim rng As Range, items As New Collection, myitem As New Dictionary, subitem As New Dictionary, i As Integer, cell As Variant
Set rng = Range("A2:A7103")
'Set rng = Range(Sheets(2).Range("A2"), Sheets(2).Range("A3").End(xlDown)) use this for dynamic range
i = 0
For Each cell In rng
Debug.Print (cell.Value)

myitem("article") = cell.Value

subitem("ru") = cell.Offset(0, 1).Value
myitem.Add "title", subitem
Set subitem = New Dictionary

myitem("brand") = cell.Offset(0, 3).Value
myitem("parent") = cell.Offset(0, 4).Value
myitem("price") = cell.Offset(0, 5).Value
myitem("currency") = cell.Offset(0, 6).Value
myitem("display_in_showcase") = cell.Offset(0, 7).Value
myitem("presence") = cell.Offset(0, 8).Value

subitem("minimalnoeKolichestvoKZakazu") = cell.Offset(0, 8).Value
subitem("kolichestvo") = cell.Offset(0, 9).Value
myitem.Add "characteristics", subitem

items.Add myitem

Set myitem = Nothing
Set subitem = Nothing
i = i + 1
Next
myFile = Application.DefaultFilePath & "\" & savename
    Open myFile For Output As #1
    Print #1, ConvertToJson(items, Whitespace:=2)
    Close #1
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