Snasui Excel Forum

Code: Select all

Sub cJs()
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 & ":[" & f & "{"
    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 & q & r & q
            k = k + 1
        End If
    Next r
    If k > 0 Then
        ReDim Preserve c(j)
        c(j) = h & f & Join(a, "," & f) & f & "}," & f & f & _
            h & f & Join(b, "," & f) & "}"
        j = j + 1
    End If
Next i
[f15] = "{" & Join(c, "," & f & f) & f & "}"

End Sub

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 = [d:d].SpecialCells(xlCellTypeConstants)
For i = 1 To ra.Areas.Count
    Set rs = ra.Areas(i)
    h = q & Cells(rs(1).Row - 1, 1) & q & ":[" & f & "{"
    k = 0
    For Each r In rs
        If Val(r) Then
            ReDim Preserve a(k), b(k)
            l = q & r.Offset(0, -3) & q & ":"
        
         a(k) = l & q & r.Offset(0, -2) & q: b(k) = l & q & r & q
            k = k + 1
        End If
    Next r
    If k > 0 Then
        ReDim Preserve c(j)
        c(j) = h & f & Join(a, "," & f) & f & "}," & f & _
            "{" & f & Join(b, "," & f) & f & "}" & "]"
        j = j + 1
    End If
Next i
[f15] = "{" & Join(c, "," & f & f) & f & "}"

Code: Select all

'Other code
'If Val(r) Then
ReDim Preserve a(k), b(k)
l = q & r.Offset(0, -3) & q & ":"

a(k) = l & q & r.Offset(0, -2) & q: b(k) = l & q & r & q
k = k + 1
'End If
'Other code