將JSON靜態匯入Excel并使用PowerQuery/VBA將結果添加到現有表

我有一個用于比較各種測驗結果的 Excel 作業簿。結果被組織在作業簿內的表格中。對于每次測驗運行，測驗腳本本身將生成一個包含相應運行結果的 json 檔案，例如：

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

列出所有測驗的 Excel 表如下所示：

我正在尋找一種靜態匯入 json 檔案并將結果附加到串列的方法。表格的行不應連接到相應的 json 檔案，因為這些行可能會在之后被洗掉。

我創建了一個 PowerQuery 來加載單個 json 檔案并將其轉換為適當的格式（表格的格式）。現在我想創建一個靜態（非連接）副本并將其添加到現有串列中。匯入作業流程是：

1. 用戶點擊“匯入結果”
2. 提示用戶選擇一個或多個 json 檔案（通過 VBA 宏）
3. Json 檔案通過 PowerQuery 決議
4. 資料的靜態版本附加到串列中

這是我的 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 檔案。我現在需要做的就是將資料附加到現有的（靜態）表中。有誰知道如何實作這一目標？這是否可以通過 PowerQuery 實作，或者我需要 VBA 嗎？

在此先感謝您的幫助。

uj5u.com熱心網友回復：

我撰寫了以下代碼，嚴重依賴這篇文章：如何在 VBA 中自動執行電源查詢？

設定：將 PowerQuery 腳本的文本放在與作業簿相同的檔案夾中名為 import_json.txt 的文本檔案中。將以下代碼復制到通用代碼模塊中

運行名為 import_data 的子程序，代碼將提示用戶打開一個 json 檔案（必須以“.json”結尾）并匯入資料，并將其附加到活動作業表上資料的底部。

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$1")).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

uj5u.com熱心網友回復：

這是一個使用 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

uj5u.com熱心網友回復：

我已經用一個簡單的 VBA 腳本解決了這個問題。我正在為 PowerQuery 資料使用單獨的作業表，并使用一個命名單元“FilePath”將引數從 VBA 腳本傳輸到 PowerQuery。VBA sripct 提示輸入檔案，更新 FilePath 單元格的值，重繪 PowerQuery 并將結果作為新行添加到我的結果表頂部。

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

電源查詢：

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 擅长 vba 电源查询

上一篇：MSProject-使用VBA添加“后繼者”列

下一篇：如何在C#MVC中使用AzureAD實作注銷后