Untitled

Sub RowsToKeyValuePairs()
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long, j As Long
    Dim jsonStr As String
    
    ' Find the last row and column with data
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    ' Start building the key-value pairs
    jsonStr = "#{" & vbCrLf
    
    ' Loop through each attribute in the first row
    For j = 1 To lastCol
        jsonStr = jsonStr & "  " & Cells(1, j).Value & " => ["
        
        ' Loop through each value in the further rows
        For i = 2 To lastRow
            jsonStr = jsonStr & """" & Cells(i, j).Value & """"
            
            ' Add a comma if it's not the last row
            If i < lastRow Then
                jsonStr = jsonStr & ","
            End If
        Next i
        
        ' Close the list of values and add a comma if it's not the last attribute
        jsonStr = jsonStr & "]"
        If j < lastCol Then
            jsonStr = jsonStr & ","
        End If
        
        jsonStr = jsonStr & vbCrLf
    Next j
    
    ' Close the overall key-value pair
    jsonStr = jsonStr & "}"
    
    ' Print the key-value pairs in the Immediate Window (for testing)
    Debug.Print jsonStr
    
    ' Optionally, you can save the key-value pairs to a file
    ' Open "C:\Path\To\Your\File.txt" For Output As #1
    ' Print #1, jsonStr
    ' Close #1
End Sub