VBA Export in JSON Umlaute

Public Sub tojson() savename = "exportedxls.json" 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 json = "[" dq = """" For j = 2 To lrow For i = 1 To lcolumn If i = 1 Then json = json & "{" End If cellvalue = wks.Cells(j, i) json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq If i > lcolumn Then json = json & "," End If Next i json = json & "}" If j > lrow Then json = json & "," End If Next j json = json & "]" myFile = Application.DefaultFilePath & "\" & savename Open myFile For Output As #1 Print #1, json Close #1 a = MsgBox("Saved as " & savename, vbOKOnly) End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Mobby,

es könnte daran liegen, dass die Datei als Unicode gespeichert werden soll. Dafür verwende am Besten die Methode "CreateTextFile" vom Objekt "FileSystemObject". Diese ist in der Bibliothek Microsoft Scripting Runtime abgelegt: in VB-Editor, unter "Extras", "Verweise...", Haken bei "Micorsoft Scripting Runtime".

Für ein leichtere Behandlung würde ich die "Liste" temporäre in einer Tabelle packen, dann das kombinieren der Überschrift und Zeile in einer abgelegten Function, um ein besseren Übersicht zu haben.
Das Gesamt würde so aussehen:

Public Sub tojson()

'Unter Anbindung ("Extras", "Verweise..") von

'Microsoft Scripting Runtime

Dim LR As ListRow

Dim FSO As New FileSystemObject 'Bib: Scripting

Dim Json  As String

Const savename = "exportedxls.json"



    With ThisWorkbook.Sheets(1)

        With .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes)

        'json Zeilen herstellen

            For Each LR In .ListRows

                Json = Json & ",{" & Join(Kombiniere(.HeaderRowRange.Value, LR.Range.Value), ",") & "}"

            Next

            .Unlist

        End With

    End With

'Json vervollständigen

    Json = "[" & Mid(Json, 2) & "]" 'führende Komma weg

'in die Datei schreiben

    With FSO.CreateTextFile(Application.DefaultFilePath & "\" & savename, OverWrite:=True, Unicode:=True)

        .Write Json

        .Close

    End With

    MsgBox "Saved as " & savename, vbOKOnly

End Sub



Private Function Kombiniere(ArrHead, ArrLR)

Dim i

Dim Erg

Const cDQ = """"

    ReDim Erg(LBound(ArrHead, 2) To UBound(ArrHead, 2))

    For i = LBound(ArrHead, 2) To UBound(ArrHead, 2)

        Erg(i) = cDQ & ArrHead(1, i) & cDQ & ":" & cDQ & ArrLR(1, i) & cDQ

    Next

    Kombiniere = Erg

End Function

Nicht gestestet, da ich keine passende Daten/Datei dafür habe.
Ich gehe davon aus, dass im normalen Zustand keine Tabelle (aka "intelligente Tabelle", Menü "Einfügen", "Tabelle") vorhanden ist. Sollte schon eine geben, müsste man darauf bauen.

VG
Yal

Public Sub AlsJson_speichern() Const savename = "exportedxls.json" With CreateObject("Scripting.Runtime").CreateTextFile(Application.DefaultFilePath & "\" & savename, True, True) .Write Daten_Lesen .Close End With MsgBox "Saved as " & savename End Sub Private Function Daten_Lesen() Dim temp As String Dim Json As String Dim R, C With ThisWorkbook.Sheets(1) For R = 2 To .Cells(Rows.Count, "A").End(xlUp).Row temp = "" For C = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column temp = temp & ",""" & .Cells(1, C).Value & """:""" & .Cells(R, C).Value & """" Next C Json = Json & ",{" & Mid(temp, 2) & "}" 'ohne das führende Komma in temp, also ab der 2te Stelle. Next R End With Daten_Lesen = "[" & Mid(Json, 2) & "]" 'ohne das führende Komma in json End Function

Public Sub AlsJson_speichern() Const savename = "exportedxls.json" With CreateObject("Scripting.FileSystemObject").CreateTextFile(Application.DefaultFilePath & "\" & savename, True, True) .Write Daten_Lesen .Close End With MsgBox "Saved as " & savename End Sub Private Function Daten_Lesen() Dim temp As String Dim Json As String Dim R, C With ThisWorkbook.Sheets(1) For R = 2 To .Cells(Rows.Count, "A").End(xlUp).Row temp = "" For C = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column temp = temp & ",""" & .Cells(1, C).Value & """:""" & .Cells(R, C).Value & """" Next C Json = Json & ",{" & Mid(temp, 2) & "}" 'ohne das führende Komma in temp, also ab der 2te Stelle. Next R End With Daten_Lesen = "[" & Mid(Json, 2) & "]" 'ohne das führende Komma in json End Function

Hallo Mobby,

sorry, ich habe bei meiner Erklärung 2 Sachen vermischt, die "entweder oder" anzunehmen sind:

Entweder sogenannte Frühbindung: man hakt die passende Bibliothek in den "Verweise" und verwendet den FileSystemObject in den Variablendeklaration:
Dim FSO As FileSystemObject

Oder late binding: die Variable wird generisch als "Objekt" deklariert und mit CreateObject als FileSystemObject richtig instanziert. Da braucht man den Verweis nicht.

Du musst den late binding Test machen:

Sub Test

Dim FSO As Object



    Set FSO = CreateObject("Scripting.FileSystemObject")

End Sub

Lasse den Code im Schrittmodus laufen (F8) beim offenen Lokalfenster (Ansicht, Lokalfenster) und siehe, wie die Variable FSO instanziert wird.
Das sollte unter Mac auch funktionieren. Wenn nicht, müssen wir eine andere Lösung suchen.

Ich mache es ein bisschen kompliziert, weil ich mit dem "with" eine direkte Verwendung des Objekts ohne Zuweisung an einer Variable.

VG
Yal

Sub Makro1() Const cPfad = "C:\HerberForum\" With Workbooks.Add .Worksheets(1).Range("A1").Value = json 'Vers 1, csv .SaveAs Filename:=cPfad & "test.csv", FileFormat:=xlCSVUTF8, CreateBackup:=False 'Vers 2, txt .SaveAs Filename:=cPfad & "test.csv", FileFormat:=xlTextMac, CreateBackup:=False .Close SaveChanges:=False End With End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread