แปลงข้อมูลเป็น Json ให้เป็นไปตามไฟล์แนบ

[wisitsakbenz]

เรียน อาจารย์

ต้องการแปลงข้อมูลเป็น Json ให้เป็นไปตามไฟล์แนบ
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Function toJSON(rangeToParse As Range, parseAsArrays As Boolean) As String
    Dim rowCounter As Integer
    Dim columnCounter As Integer
    Dim parsedData As String: parsedData = "["
    Dim temp As String

    If parseAsArrays Then ' Check to see if we need to make our JSON an array; if not, we'll make it an object.
    
    For rowCounter = 2 To rangeToParse.Rows.Count ' Loop through each row starting with the second row so we don't include the header
            temp = "" ' Reset temp's value
            
            For columnCounter = 1 To rangeToParse.Columns.Count ' Loop through each column
                temp = temp & """" & rangeToParse.Cells(1, columnCounter) & """" & ","
            Next

            temp = "{" & Left(temp, Len(temp) - 1) & "}," ' Remove extra comma from after last object
            parsedData = parsedData & temp ' Add temp to the data we've already parsed
        Next
        
    Else
                For rowCounter = 1 To rangeToParse.Rows.Count ' Loop through each row
            temp = "" ' Reset temp's value

            For columnCounter = 1 To rangeToParse.Columns.Count ' Loop through each column
                temp = temp & """" & rangeToParse.Cells(rowCounter, columnCounter) & """" & ":" & """" & rangeToParse.Cells(rowCounter, columnCounter) & """" & ","
            Next

            temp = "[" & Left(temp, Len(temp) - 1) & "]," ' Remove extra comma from after last object
            parsedData = parsedData & temp ' Add temp to the data we've already parsed
        Next
    End If


    parsedData = Left(parsedData, Len(parsedData) - 1) & "]" ' Remove extra comma and add the closing bracket for the JSON array
    toJSON = parsedData ' Return the JSON data
End Function

[snasui]

ตัวอย่างการปรับ Code ซึ่งแสดงคำตอบที่ F15 ครับ

Code: Select all

Dim rs As Range, r As Range
Dim qt$, v$, a$
Dim strArr(), i%, j%
Dim strJson$, strF$, c1$
With Worksheets("Sheet1")
    Set rs = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
    qt = Chr(34)
    a = .Range("a1").Value
    strF = qt & a & qt & ","
    For i = 1 To 2
        j = 0
        For Each r In rs
            ReDim Preserve strArr(j)
            c1 = qt & r.Value & qt & Chr(58)
            v = r.Offset(0, i).Value
            If Len(v) = 0 Then
                strArr(j) = c1 & qt & qt
            ElseIf IsNumeric(v) Then
                strArr(j) = c1 & v
            Else
                strArr(j) = c1 & qt & v & qt
            End If
            j = j + 1
        Next r
        strJson = strJson & IIf(i > 1, vbLf & strF & "{", ",{") & _
            vbLf & VBA.Join(strArr, "," & vbLf) & "}"
    Next i
    .Range("f15").Value = "[" & qt & a & qt & strJson & "]"
End With

[Bo_ry]

Code: Select all

Sub cJs()
    Dim r As Range, q$, n$, a, b(1), i&, j&
    q = """": n = vbLf
    a = [A1].CurrentRegion
    For i = 1 To UBound(a)
        For j = 1 To 3
            If Not Application.IsNumber(a(i, j)) Then a(i, j) = q & a(i, j) & q
            If i > 1 And j > 1 Then b(j - 2) = b(j - 2) & "," & n & a(i, 1) & ":" & a(i, j)
    Next j, i
    [f15] = "[" & a(1, 1) & ",{" & Mid(b(0), 2) & "}," & n & a(1, 1) & ",{" & Mid(b(1), 2) & "}]"
End Sub

[snasui]

อีกแบบครับ

Code: Select all

Dim a, b, c, q$, h$, i%, j%, f$, v$
q = Chr(34): f = vbLf: a = [a1].CurrentRegion
ReDim b(1 To UBound(a, 1) - 1), c(1 To UBound(a, 2) - 1)
For i = 1 To UBound(c)
    For j = 2 To UBound(a)
        v = a(j, i + 1)
        b(j - 1) = q & a(j, 1) & q & ":" & IIf(VarType(v) <> 5, q & v & q, v)
    Next j
    c(i) = Join(b, "," & f)
Next i
h = q & [a1] & q & ",{" & f: [f15] = "[" & h & Join(c, "}" & f & h) & "}]"

[wisitsakbenz]

เรียนอาจารย์ครับ

ขออภัยอาจารย์ที่ตอบล่าช้านะครับ
คำตอบไม่ได้ตามต้องการครับ อยากให้คำตอบแสดงผลตามไฮไลท์สีเหลืองครับ
สิ่งที่ต้องการเพิ่มเติมคือ ถ้าค่าใน Column C เป็น 0 จะไม่แสดงในคำตอบครับ
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub cJs()
Dim a, b, c, q$, h$, i%, j%, f$, v$
q = Chr(34): f = vbLf: a = [a1].CurrentRegion
ReDim b(1 To UBound(a, 1) - 1), c(1 To UBound(a, 2) - 1)
For i = 1 To UBound(c)
    For j = 2 To UBound(a)
        v = a(j, i + 1)
        b(j - 1) = q & a(j, 1) & q & ":" & IIf(VarType(v) <> 5, q & v & q, v)
    Next j
    c(i) = Join(b, "," & f)
Next i
h = q & [a1] & q & ",{" & f: [f15] = "[" & h & Join(c, "}" & f & h) & "}]"


End Sub

[snasui]

ตัวอย่างผลลัพธ์ที่ให้มาในคราวก่อนแตกต่างกับโพสต์ #5 จึงทำให้ไม่ได้คำตอบครับ

ตัวอย่างการปรับ Code ครับ

Code: Select all

Dim ra As Range, rs As Range, r As Range
Dim h$, q$, l$, f$, i%, j%, k%, a(), b(), c()
q = Chr(34): f = vbLf
Set ra = [c:c].SpecialCells(xlCellTypeConstants)
For i = 1 To ra.Areas.Count
    Set rs = ra.Areas(i)
    h = q & Cells(rs(1).Row - 1, 1) & q & ",{"
    k = 0
    For Each r In rs
        If Val(r) Then
            ReDim Preserve a(k), b(k)
            l = q & r.Offset(0, -2) & q & ":"
            a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & r
            k = k + 1
        End If
    Next r
    If k > 0 Then
        ReDim Preserve c(j)
        c(j) = h & f & Join(a, "," & f) & "}," & f & f & _
            h & f & Join(b, "," & f) & "}"
        j = j + 1
    End If
Next i
[f15] = "[" & Join(c, "," & f & f) & "]"

[wisitsakbenz]

เรียน อาจารย์

ค่าของ Clumn C ไม่มี "....."

อยากให้แสดงดังนี้ (ตัวอย่าง)
"Drugs and Parenteral Nutrition",{
"IV Fluid":"100",
"Medication":"101",
"Vaccine":"102",
"Oxygen":"103",
"Special Medication":"104",
"Home Medication":"105"},

ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

[snasui]

กรณีต้องการให้ค่าในคอลัมน์ C ครอบด้วยฟันหนูด้วยลองปรับมาเองก่อน ติดตรงไหนค่อยถามกันต่อ

ควรจะปรับมาเองก่อนเสมอ ยิ่งเป็นกรณีนี้ถือว่าเป็นเรื่องง่าย สังเกตว่า Code แสดงผลลัพธ์ของคอลัมน์ B เป็นแบบนั้นได้ก็แสดงว่าต้องทำเช่นเดียวกันกับคอลัมน์ C ได้ด้วยครับ

บรรทัดที่ต้องปรับคือ a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & r

โดยส่วนนี้ l & q & r.Offset(0, -1) & q คือการจัดการค่าในคอลัมน์ B และส่วนนี้คือการจัดการค่าในคอลัมน์ C l & r

[Bo_ry]

Code: Select all

Sub cJs()
Dim r As Range, q$, n$, a, b, i&, j&, js$, h$, c$
q = """": n = vbLf: c = "}," & n
For Each r In Columns(2).SpecialCells(2).Areas
    ReDim b(1)
    a = r.Offset(, -1).Resize(, 3).Value2
    h = q & r(0, 0) & q & ",{"
    For i = 1 To UBound(a)
        For j = 1 To 3
            If Not Application.IsNumber(a(i, j)) Then a(i, j) = q & a(i, j) & q
            If j > 1 And a(i, 3) > 0 Then b(j - 2) = b(j - 2) & "," & n & a(i, 1) & ":" & a(i, j)
    Next j, i
    If b(0) <> "" Then js = js & n & h & Mid(b(0), 2) & c & n & h & Mid(b(1), 2) & c
Next
    [f15] = "[" & Mid(js, 2) & "]"
End Sub

[wisitsakbenz]

เรียน อาจารย์ snasui และอาจารย์ Bo_ry

ผมแก้ไขได้แล้วนะครับโดยการ

Code: Select all

a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & """" & r & """"

แต่ผมทำการ Copy ข้อมูลในช่อง F15 แล้วไปวางใน Notepad มันจะเพิ่ม --> " เข้ามา (ไฟล์แนบ Copypaste)
ถ้าอยากให้ Copy > Paste แล้วได้ผลลัพท์เหมือนเดิม อาจารย์พอมีวิธีหรือไม่ครับ ขอบคุณครับ

[logic]

a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & """" & r & """"

แบบนั้นก็ใช้ได้ หรือถ้าทำแนวอาจารย์ก็ใช้ตัว q แทน " ครับ

a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & q & r & q

ส่วนวางใน Notepad ผมก็มี " เพิ่มเข้ามาเหมือนกัน แก้เร็ว ๆ ไปด้วยการแทนที่ไปก่อนก็ได้นะครับคือ

ลากเมาส์คลุมอักษร "" แล้วกดปุ่ม Ctrl+H ~~> ช่องล่างคีย์อักษร " ~~> กดปุ่ม Replace All

[wisitsakbenz]

เรียน อาจารย์ logic, อาจารย์ snasui และอาจารย์ Bo_ry

ได้ครับ แต่ในมุม User มันจะเสียเวลาครับ
อาจารย์พอมีวิธีหรือไม่ครับ ขอบคุณครับ

[logic]

แล้วถ้าใช้แบบนี้จะช่วยได้ไหม

เพิ่ม Clean เข้าไปครอบ [f15] = Application.Clean("[" & Join(c, "," & f & f) & "]")

ไปเจอปัญหาเดียวกันจากที่นี่ครับ https://stackoverflow.com/questions/249 ... 7#24913557

[wisitsakbenz]

เรียน อาจารย์ logic , อาจารย์ snasui และอาจารย์ Bo_ry

ได้ครับ สอบถามเพิ่มเติมครับ
ถ้าต้องการเอาคำตอบใน ช่อง F15 Export หรือ Save เป็นไฟล์ JSON (ตัวอย่างดังรูป) ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Private Sub CommandButton1_Click()

'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")


'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = Sheets("Sheet1").Range("G2").Value & "_" & Sheets("Sheet1").Range("G3").Value & ".json"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="JSON Files (*.json), *.json", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypeJSONFile, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "JSON file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create JSON file"
    Resume exitHandler

End Sub

[logic]

ลองดูว่าใช้ได้ไหมครับ

Code: Select all

Private Sub CommandButton1_Click()

'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant

On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = Sheets("Sheet1").Range("G2").Value & "_" & Sheets("Sheet1").Range("G3").Value & ".json"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
'    (InitialFileName:=strPathFile, _
'        FileFilter:="JSON Files (*.json), *.json", _
'        Title:="Select Folder and FileName to save")

Dim jsonEpt As Object
Dim jsonFobj As Object

Set jsonFobj = CreateObject("Scripting.FileSystemObject")
Set jsonEpt = jsonFobj.CreateTextFile(strFile, True)
jsonEpt.WriteLine ([f15])

'export to PDF if a folder was selected
'If myFile <> "False" Then
'    wsA.ExportAsFixedFormat _
'        Type:=xlTypeJSONFile, _
'        Filename:=myFile, _
'        Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, _
'        IgnorePrintAreas:=False, _
'        OpenAfterPublish:=False
'    'confirmation message with file info
'    MsgBox "JSON file has been created: " _
'      & vbCrLf _
'      & myFile
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create JSON file"
    Resume exitHandler

End Sub

[wisitsakbenz]

เรียน อาจารย์ logic

ได้ครับ และอยากให้เลือก Path ที่จัดเก็บ และอาจจะเพิ่มหรือแก้ไขชื่อไฟล์ด้วยครับ ต้องแก้ไข Code อย่างไรครับ ขอบคุณครับ

[logic]

มีโค้ดเดิมอยู่แล้วลองเปิดใช้ดูเองเลย หรืออยากได้แบบไหนลองเขียนมาก่อนได้ครับ

[wisitsakbenz]

เรียน อาจารย์ logic

ผมปรับในส่วนนี้ สามารถทำได้แล้วครับ ไม่แน่ใจว่าผมทำปรับ Code ถูกหรือไม่
ขอคำแนะนำด้วยครับ ขอบคุณครับ

Code: Select all

--other Code-----
' select folder for file
myFile = Application.GetSaveAsFilename _
        (InitialFileName:=strPathFile, _
        FileFilter:="JSON Files (*.json), *.json", _
        Title:="Select Folder and FileName to save")

Dim jsonEpt As Object
Dim jsonFobj As Object

Set jsonFobj = CreateObject("Scripting.FileSystemObject")
Set jsonEpt = jsonFobj.CreateTextFile(myFile, True)
jsonEpt.WriteLine ([f15])

--other Code-----

[logic]

ผมปรับในส่วนนี้ สามารถทำได้แล้วครับ

ก็ถือว่าได้แล้ว เอาไว้ติดบั๊กค่อยว่ากันครับ

[wisitsakbenz]

ขอบคุณอาจารย์ logic มาก ๆ เลยครับ