Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA: Excel to Json (Nested Objects)
 
#1
05.02.2020 13:24:25
Уважаемые специалисты,

Есть вот такая структура EXCEL файла и макрос (файл в приложении)
Сам макрос:
Скрытый текст

Получаю вот такую структуру по выходу:
Скрытый текст
Как видно вложенные объекты "title" и "characreristics" дублируются.
А необходимо, чтобы вложенные объекты не дублировались и получалась вот такая структура
Скрытый текст
Перерыл интернет но так и не нашел решения по вложенным объектам.
Может кто сталкивался?

Заранее благодарю!
 
 
 
#2
05.02.2020 13:50:30
99% времени ушло  на то, чтобы понять, что Вам надо. В коде переменная subitem не обнуляется и поэтому, когда оно во второй раз используются, то остаются старые значения.
Код
...
myitem("presence") = cell.Offset(0, .Value 
Set subitem = New Dictionary    'добавить или эту строчку или следующую на выбор просто первую я сам написал, а вторую в Вашем коде увидел. В чём разница не совсем понимаю.
Set subitem = Nothing 
subitem("minimalnoeKolichestvoKZakazu") = cell.Offset(0, .Value
...
Ну или вводить переменную subitem0

И вообще, обнулять subitem лучше сразу после строчки
Код
myitem.Add "title", subitem
Изменено: Wiss - 05.02.2020 13:56:52
Я не волшебник, я только учусь.
 
 
 
#3
05.02.2020 15:40:28
Wiss, Спасибо большое, все заработало.  
Изменено: Agryzkov - 05.02.2020 16:03:12
 
 
 
#4
05.02.2020 15:58:57
Цитата
Agryzkov написал:
Подскажите, если не сложно, как реализовать сохранение в файл, а не в ячейку?
Если в текстовый файл, то без обид, но это тупо к гуглу. Вот первая же ссылка.
А если в Эксель, то вместо строчки
Код
Sheets(2).Range("A7").Value = ConvertToJson(items, Whitespace:=2)
что-то типа:
Код
    With Application.Workbooks.Add
        .Worksheets(1).Cells(1, 1).Value =  ConvertToJson(items, Whitespace:=2)
        .SaveAs ThisWorkbook.Path & "\1231.xlsx", 51
        .Close
    End With
P.S. ConvertToJson() возвращает String, так что и обращаться с ним так же просто как и со строковой переменной.  
Изменено: Wiss - 05.02.2020 16:02:41
Я не волшебник, я только учусь.
 
 
 
#5
05.02.2020 16:03:47
Wiss,Спасибо большое! Все получилось!
 
 
 
#6
05.02.2020 16:41:55
Может стОит сразу сохранять в файл с расширением ".json"?
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#7
06.02.2020 15:35:39
Nordheim, Да, сразу в файл и выгружаю.

Но не могу понять почему больше 1000 строк уже тормозит и не отрабатывает макрос. У меня задача от 50 000 строк.  
 
 
 
#8
06.02.2020 15:40:38
При таком объёме есть смысл уходить от перебора ячеек на перебор массива.
Массив из 10 столбцов должен поместиться в память.
А вообще можно померить где какие потери времени, может и ConvertToJson тормозит, я не знаю что там и как, никогда не работал с этим.
Изменено: Hugo - 06.02.2020 15:45:34
 
 
 
#9
06.02.2020 18:04:51
Размножил данные из #1 на 10000 строк. Строка Json формируется моментально. Еще раз выложите файл на 100 строк с новым текстом макроса. И учтите, что если Вы все-таки пишите в ячейку Excel, то общее количество знаков в ячейке ограничено 32 767 знаками.
Изменено: sokol92 - 06.02.2020 18:07:33
Владимир
 
 
 
#10
06.02.2020 18:50:04
sokol92, Я добавил выгрузку сразу в файл Json
Код
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

Протестировал на 7100, но очень долго конечно.

Порекомендуйте пожалуйста в какую сторону смотреть по оптимизации макроса?
 
 
 
#11
06.02.2020 19:14:45
Так я ведь написал - перебирать массив, а не ячейки.
 
 
 
#12
06.02.2020 19:24:13
Hugo,  я новичек в этом деле, буду очень благодарен если напишите как изменить ренж на массив.

Заранее благодарю!
Изменено: Agryzkov - 06.02.2020 19:24:29
 
 
 
#13
06.02.2020 19:27:42
У меня уходит 7 секунд на формирование колекции Items и 1 секунда на запись в файл. Естественно, нужно предварительно закомментировать строку с Debug.Print.
Но вообще, большая беда - создавать новые объекты в цикле (строка 14), чреватая к тому же утечкой оперативной памяти. Можно поменять алгоритм действий:
  • откройте файл и запишите в него "["
  • Цикл по строкам. Для каждой строки формируйте соответствующий объект и сразу выводите в файл. Не забудьте о запятой, разделяющей объекты
  • запишите в файл "]"  и закройте его

Владимир
 
 
 
#14
06.02.2020 20:23:28
Цитата
Agryzkov написал:
буду очень благодарен если напишите как изменить ренж на массив
В процессе нашёл ошибку с количеством - брали не ту ячейку.
На массиве ускорило перебор/формирование только в 2 раза, очевидно много времени уходит на создание коллекции словарей.
Код
Public Sub subitem()
'Dim tm!: tm = Timer
    savename = "exportedxls.json"
    Dim rng, items As New Collection, myitem As New Dictionary, subitem As New Dictionary, i As Long
    rng = Range("A2:K7103")
    For i = 1 To UBound(rng)

        myitem("article") = rng(i, 1)    'cell.Value

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

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

        subitem("minimalnoeKolichestvoKZakazu") = rng(i, 10)    'cell.Offset(0, 8).Value - ОШИБКА
        subitem("kolichestvo") = rng(i, 11)    'cell.Offset(0, 9).Value - ОШИБКА
        myitem.Add "characteristics", subitem

        items.Add myitem

        Set myitem = Nothing
        Set subitem = Nothing
    Next
    'Debug.Print 1 & " - " & Timer - tm
    myFile = Application.DefaultFilePath & "\" & savename
    Open myFile For Output As #1
    Print #1, ConvertToJson(items, Whitespace:=2)
    Close #1
    'Debug.Print 2 & " - " & Timer - tm

End Sub
 
 
 
#15
06.02.2020 20:32:56
Hugo,Спасибо большое, это уже результат!!!
 
 
 
#16
06.02.2020 22:04:03
sokol92, такой алгоритм у меня реализован в другом макросе, если я правильно понял,
Код
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

Но я не могу реализовать вложенные объекты, поэтому и взял с item, subitem.
 
 
 
Страницы: 1
Наверх