将 JSON 静态导入到 Excel 并将结果添加到现有 table 和 PowerQuery/VBA

Question

我有一个 excel 工作簿用于比较各种测试结果。结果组织在工作簿中的 table 中。对于每个测试运行，测试脚本本身将生成一个 json 文件，其中包含相应运行的结果，例如：

{
  "name": "dummy",
  "score1": 100,
  "scoreX": 99.4,
  "TestXY": {
    "scoreXYa": 34.5,
    "scoreXYb": 45.7
  }
}

列出所有测试的 excel table 如下所示：

name	score1	scoreX	TestXY.scoreXYa	TestXY.scoreXYa
dummy1	100	99.4	34.5	45.7
dummy2	120	87.0	32.5	45.3
dummy3	104	98.2	36.4	45.5

我正在寻找一种静态导入 json 文件并将结果附加到列表的方法。 table 的行不应连接到相应的 json 文件，因为这些行之后可能会被删除。

我创建了一个 PowerQuery 来加载单个 json 文件并将其转换为适当的格式（table 的格式）。现在我想创建一个静态（非连接）副本并将其添加到现有列表中。导入工作流是：

用户点击'Import Result'
用户被提示 select 一个或多个 json 文件（通过 VBA 宏）
Json 文件通过 PowerQuery
数据的静态版本附加到列表

这是我的 PowerQuery 脚本：

let
    Source = Json.Document(File.Contents(filename)),
    #"Converted to Table" = Record.ToTable(Source),
    #"Transposed Table" = Table.Transpose(#"Converted to Table"),
    #"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table", [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"name", type text}, {"score1", Int64.Type}, {"scoreX", type number}, {"TestXY", type any}}),
    #"Expanded TestXY" = Table.ExpandRecordColumn(#"Changed Type", "TestXY", {"scoreXYa", "scoreXYb"}, {"TestXY.scoreXYa", "TestXY.scoreXYb"})
in
    #"Expanded TestXY"

我能够解析 json 文件。我现在需要做的就是将数据附加到现有的（静态）table。有谁知道如何实现这一目标？这可以通过 PowerQuery 实现还是我需要 VBA？

在此先感谢您的帮助。

Answer 1

我写了下面的代码，严重依赖这个post：

设置：将 PowerQuery 脚本的文本放在与工作簿相同的文件夹中名为 import_json.txt 的文本文件中。将下面的代码复制到通用代码模块中

运行名为 import_data 的子过程，代码将提示用户打开一个 json 文件（必须以“.json”结尾）并导入数据，将其附加到活动 sheet.

上数据的底部

Option Explicit

Sub import_data()
    Dim jsonPaths As Collection
    Dim jsonPath As Variant
    Dim mScript As String
    Dim qry As WorkbookQuery
    Dim qName As String
    Dim jsonSheet As Worksheet
    Dim dataSheet As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set dataSheet = ActiveSheet ' use to append json to activesheet
    'Set dataSheet = worksheets("Sheet1") ' use to append json to a specific sheet
    
    Set jsonPaths = get_file_path("*.json")
    
    ' get out of here if the user cancelled the file dialog
    If jsonPaths Is Nothing Then Exit Sub
    
    
    For Each jsonPath In jsonPaths
        
        ' read in the power query script
        mScript = get_file_as_string(ThisWorkbook.path & "\import_json.txt")
        
        ' adjust the script to find the json file the user chose
        mScript = Replace(mScript, "filename", Chr(34) & jsonPath & Chr(34))
        
        ' set the name of the query
        qName = "test_resutls"
        
        If DoesQueryExist(qName) Then
            ' Deleting the query
            Set qry = ThisWorkbook.Queries(qName)
            qry.Delete
        End If
                   
        ' add the query
        Set qry = ThisWorkbook.Queries.Add(qName, mScript)
        
        ' We add a new worksheet with the same name as the Power Query query
        Set jsonSheet = Sheets.Add
        LoadToWorksheetOnly qry, jsonSheet
        
        'copy data from import sheet to data sheet
        Intersect(jsonSheet.Rows(2), jsonSheet.UsedRange).Copy
        dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            
        'remove the import sheet
        jsonSheet.Delete
    Next

End Sub

Function get_file_path(Optional filter As String) As Collection
  ' allows the user to choose a file
  Dim col As Collection
  Dim fd As Office.FileDialog
  Dim x As Long
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  If filter > "" Then
    fd.Filters.Clear
    fd.Filters.Add "JSON files", filter
 End If
  
  fd.Show
  If fd.SelectedItems.Count = 0 Then Exit Function
  Set col = New Collection
  For x = 1 To fd.SelectedItems.Count
    col.Add fd.SelectedItems(x)
  Next
  Set get_file_path = col
End Function

Function get_file_as_string(path As String) As String
  'opens a text file and returns contents as a string
  Dim ff As Long
  ff = FreeFile
  Open path For Input As ff
    get_file_as_string = Input(LOF(ff), ff)
  Close ff
End Function


Function DoesQueryExist(ByVal queryName As String) As Boolean
    ' Helper function to check if a query with the given name already exists
    Dim qry As WorkbookQuery
    
    If (ThisWorkbook.Queries.Count = 0) Then
        DoesQueryExist = False
        Exit Function
    End If
    
    For Each qry In ThisWorkbook.Queries
        If (qry.Name = queryName) Then
            DoesQueryExist = True
            Exit Function
        End If
    Next
    DoesQueryExist = False
End Function


Sub LoadToWorksheetOnly(query As WorkbookQuery, currentSheet As Worksheet)
    ' The usual VBA code to create ListObject with a Query Table
    ' The interface is not new, but looks how simple is the conneciton string of Power Query:
    ' "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & query.Name
     
    With currentSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & query.Name _
        , Destination:=Range("$A")).QueryTable
        .CommandType = xlCmdDefault
        .CommandText = Array("SELECT * FROM [" & query.Name & "]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = False
        .Refresh BackgroundQuery:=False
    End With
     
End Sub

Answer 2

这是一个使用 VBA-JSON (https://github.com/VBA-tools/VBA-JSON)

的示例

非常简单。

Sub TestAddRows()
    Dim files As Collection, json As Object, f, lo As ListObject
    Dim rw As Range
    
    Set lo = Sheet6.ListObjects(1)  'Target table/listobject
    
    Set files = PickFiles()         'user selects data files
    For Each f In files
        Set json = JsonConverter.ParseJson(GetContent(CStr(f))) 'parse the json content
        'add a row and populate it
        lo.ListRows.Add.Range.Value = Array( _
            json("name"), json("score1"), json("scoreX"), _
            json("TestXY")("scoreXYa"), json("TestXY")("scoreXYb"))
    Next f
End Sub

Function PickFiles() As Collection
    Dim f As Variant, rv As New Collection
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Select one or more JSON files"
        .Filters.Clear
        .Filters.Add "JSON files", "*.json"
        If .Show Then
            For Each f In .SelectedItems
                rv.Add f
            Next
        End If
    End With
    Set PickFiles = rv
End Function

Function GetContent(f As String) As String
    GetContent = CreateObject("scripting.filesystemobject"). _
                  OpenTextFile(f, 1).ReadAll()
End Function

Answer 3

我已经用一个简单的 VBA 脚本解决了这个问题。我为 PowerQuery 数据使用单独的 sheet 和命名单元格“FilePath”，我用它来将参数从 VBA 脚本传输到 PowerQuery。 VBA sripct 提示输入文件，更新 FilePath 单元格的值，刷新 PowerQuery 并将结果作为新行添加到我的结果之上 table.

VBA代码：

Sub ImportJSON()
    Dim fDialog As FileDialog
    Dim LoaderSheet As Worksheet
    Dim ResultSheet As Worksheet
    Dim ResultTable As ListObject
    Dim AddTable As ListObject
    Dim fPath As Variant
    Dim answer As Integer
    
    Application.ScreenUpdating = False
    On Error GoTo ErrorHandler
    
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    Set LoaderSheet = ThisWorkbook.Sheets("Loader")
    Set ResultSheet = ThisWorkbook.Sheets("Results")
    Set ResultTable = ResultSheet.ListObjects("ResultTable")
    Set AddTable = LoaderSheet.ListObjects("AddResult")
    
    ResultTable.AutoFilter.ShowAllData
    
    With fDialog
        .AllowMultiSelect = True
        .Title = "Please select the files"
        .Filters.Clear
        .Filters.Add "json files", "*.json"
        .Show
        For Each fPath In .SelectedItems
            ' Update FilePath variable and update query
            LoaderSheet.Range("FilePath").Value = fPath
            ThisWorkbook.Connections(["Query - AddResult"]).OLEDBConnection.BackgroundQuery = False
            ThisWorkbook.Connections(["Query - AddResult"]).Refresh
                
            ' Copy and insert data
            LoaderSheet.ListObjects("AddResult").DataBodyRange.Copy
            ResultSheet.Rows(ResultTable.HeaderRowRange.Row + 1).Insert
            ResultSheet.Rows(ResultTable.HeaderRowRange.Row + 1).PasteSpecial xlPasteValues
        Next
    End With
    
ErrorHandler:
    Application.ScreenUpdating = True
End Sub

PowerQuery:

let
    FSource = Excel.CurrentWorkbook(){[Name="FilePath"]}[Content],
    FS = Table.TransformColumnTypes(FSource,{{"Column1", type text}}),
    Filename = FS{0}[Column1],

    Source = Json.Document(File.Contents(Filename)),
    #"Converted to Table" = Record.ToTable(Source),
    #"Transposed Table" = Table.Transpose(#"Converted to Table"),
    #"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table", [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"name", type text}, {"score1", Int64.Type}, {"scoreX", type number}, {"TestXY", type any}}),
    #"Expanded TestXY" = Table.ExpandRecordColumn(#"Changed Type", "TestXY", {"scoreXYa", "scoreXYb"}, {"TestXY.scoreXYa", "TestXY.scoreXYb"})
in
    #"Expanded TestXY"

将 JSON 静态导入到 Excel 并将结果添加到现有 table 和 PowerQuery/VBA

Statically import JSON to Excel and add results to existing table with PowerQuery/VBA

json

excel

vba

powerquery