Windows Analysis Report
Companies House Trust Excel Document.xlsm

Attribute VB_Name = "Module1"

Sub parseData()
  Worksheets("Create and copy data").Range("b12") = toJSONV2(getValuesRange("Trust"), False) ' Set cell B12's value to our JSON data
  
  
  'uncomment below to test copy to clipboard ..does not work on mac...- then replace text with above json
  'Clipboard "I can copy to the Clipboard!"
  
  ' write to file..does not work on Mac
   ' filesaveName = Application.GetSaveAsFilename(fileFilter:="JSON Files (*.json), *.json")
    ' If filesaveName <> False Then
      ' fileNumber = FreeFile
     '  Open filesaveName For Output As fileNumber
      '  Print #fileNumber, Worksheets("JSONsheet").Range("b1"); Worksheets("JSONsheet").Range("b2"); Worksheets("JSONsheet").Range("b3")
      '  Close fileNumber
   '  End If
   
   'State that copy was successful if we've got here without error
   Worksheets("Create and copy data").Range("a10") = "The data has been created and copied to your device. You can now paste it into the service."
   Worksheets("Create and copy data").Range("a10").Borders.Color = RGB(0, 0, 255)
   Worksheets("Create and copy data").Range("a10").Borders.Weight = xlThick

   ' Attempt to copy the JSON content - MUST BE LAST OPERATION
   worksheetDataCopy (Worksheets("Create and copy data").Range("b12"))

End Sub

Private Sub worksheetDataCopy(ByVal target As Range)
    If Not Intersect(target, Worksheets("Create and copy data").Range("b12")) Is Nothing Then
        target.Copy
        target.Cut
    End If
End Sub

Function Clipboard(Optional StoreText As String) As String
    Dim x As Variant
    'Store as variant for 64-bit VBA support
      x = StoreText
    'Create HTMLFile Object
    With CreateObject("htmlfile")
        With .parentWindow.clipboardData
            Select Case True
            Case Len(StoreText)
                'Write to the clipboard
             .setData "text", x
            Case Else
          'Read from the clipboard (no variable passed through)
            Clipboard = .GetData("text")
        End Select
        End With
    End With
End Function

Function getValuesRange(Sheet As String) As Range
    ' Row variables
    Dim usedRows As Integer: usedRows = 0
    Dim rowCounter As Integer: rowCounter = 1
    Dim rowsToCount As Integer: rowsToCount = 100
    ' Column variables
    Dim usedColumns As Integer: usedColumns = 0
    Dim columnCounter As Integer: columnCounter = 1
    Dim columnsToCount As Integer: columnsToCount = 50

    Do While rowCounter <= rowsToCount ' Loop through each row
        Do While columnCounter <= columnsToCount ' Loop through each column
            If Worksheets(Sheet).Cells(rowCounter, columnCounter) <> "" Then ' Check to see if the cell has a value
                usedRows = rowCounter ' Since the current row has a cell with a value in it, set usedRows to the current row
                If columnCounter > usedColumns Then
                    usedColumns = columnCounter ' If the current column is greater than usedColumns, set usedColumns to the current column
                End If
                If usedRows = rowsToCount Then
                    rowsToCount = rowsToCount + 100 ' If the value of usedRows reaches the rowsToCount limit, then extend the rowsToCount limit by 100
                End If
                If usedColumns = columnsToCount Then
                    columnsToCount = columnsToCount + 50 ' If the value of usedColumns reaches the columnsToCount limit, then extend the columnsToCount limit by 100
                End If
            End If
            columnCounter = columnCounter + 1 ' Increment columnCounter
        Loop
        rowCounter = rowCounter + 1 ' Increment rowCounter
        columnCounter = 1 ' Reset the columnCounter to 1 so we're always checking the first column every time we loop
    Loop
    Set getValuesRange = Worksheets(Sheet).Range("a5", Worksheets(Sheet).Cells(usedRows, usedColumns).Address) ' Return the range of cells that have values
End Function

Function toJSONV2(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
    Dim indSheet As String: indSheet = "Individuals involved in trust"
    Dim entSheet As String: entSheet = "Entities involved in trust"
    Dim boSheet As String: boSheet = "All beneficial owners"
    Dim keyValue As String: keyValue = ""
    
     For columnCounter = 2 To rangeToParse.Columns.Count
            temp = ""
             For rowCounter = 2 To rangeToParse.Rows.Count
                keyValue = mapnames(rangeToParse.Cells(rowCounter, 1))
                If mapnames(keyValue) <> "NO_DATA" Then
                    ' If the mapnames returns a recognised date string key - do a different construct
                    If keyValue = "dob" Or InStr(1, keyValue, "date") > 0 Then
                        dateStr = splitDates(rangeToParse.Cells(rowCounter, columnCounter), keyValue)
                        temp = temp & dateStr
                    Else
                        temp = temp & """" & mapnames(keyValue) & """" & ":" & """"
                        temp = temp & Replace(rangeToParse.Cells(rowCounter, columnCounter), """", "") & """" & ","
                    End If
                End If
            Next
            temp = temp & "," ' Remove extra comma from after last object
            parsedData = parsedData & temp
       Next
    
    If Len(parsedData) > 2 Then
        parsedData = Left(parsedData, Len(parsedData) - 2) & ","
    End If

    parsedData = parsedData & """" & "INDIVIDUALS" & """" & ": ["
    parsedData = parsedData & toJSONsubElmV2(getValuesRange(indSheet), False, 21)

    parsedData = parsedData & "],"
    parsedData = parsedData & """" & "HISTORICAL_BO" & """" & ": ["
    parsedData = parsedData & toJSONsubElmV2(getValuesRange(boSheet), False, 5) ' Set cell B1's value to our JSON data
  
    parsedData = parsedData & "],"
    parsedData = parsedData & """" & "CORPORATES" & """" & ": ["
    parsedData = parsedData & toJSONsubElmV2(getValuesRange(entSheet), False, 22) ' Set cell B1's value to our JSON data
    
    parsedData = parsedData & "]}]" ' Remove extra comma and add the closing bracket for the JSON array
    Debug.Print parsedData
    
    toJSONV2 = parsedData ' Return the JSON data
End Function

Function toJSONsubElmV2(rangeToParse As Range, parseAsArrays As Boolean, rowsToCheck As Integer) As String
    Dim rowCounter As Integer
    Dim columnCounter As Integer
    Dim parsedData As String: parsedData = ""
    Dim temp As String: temp = ""
    Dim keyValue As String: keyValue = ""
    Dim rowValue As String: rowValue = ""
    Dim dateStr As String: dateStr = ""
    Dim columnHasValue As Boolean
    
    ' work out how many columns are populated do this by checking if we have a value in the second row of each column if we have a value then increment the counter
     populatedColumns = 1
     For columnCounter = 2 To rangeToParse.Columns.Count
        For rowCounter = 2 To (rowsToCheck)
            If Len(rangeToParse.Cells(rowCounter, columnCounter)) > 0 Then ' 2 - roCounter orig value
                 populatedColumns = populatedColumns + 1
                 ' break out the loop - we know there's at least one value in the column
                 rowCounter = 100
            End If
        Next
     Next
    
    For columnCounter = 2 To populatedColumns
            temp = ""
            columnHasValue = False
            For rowCounter = 2 To rangeToParse.Rows.Count
                keyValue = mapnames(rangeToParse.Cells(rowCounter, 1))
                rowValue = rangeToParse.Cells(rowCounter, columnCounter)
                If keyValue <> "NO_DATA" And Len(rowValue) > 0 Or rowValue <> "" Then
                    ' If the mapnames returns a recognised date string key - do a different construct
                    If keyValue = "dob" Or InStr(1, keyValue, "date") > 0 Then
                        dateStr = splitDates(rowValue, keyValue)
                        temp = temp & dateStr
                        columnHasValue = True
                    Else
                        temp = temp & """" & keyValue & """" & ":" & """"
                        temp = temp & Replace(rowValue, """", "") & """" & ","
                        columnHasValue = True
                    End If
                End If
            Next
        If columnHasValue = True Then
            temp = "{" & Left(temp, Len(temp) - 1) & "},"
            parsedData = parsedData & temp
        End If
    Next
    If Len(parsedData) > 1 Then
        parsedData = Left(parsedData, Len(parsedData) - 1)  ' Remove extra comma and add the closing bracket for the JSON array
    End If
    toJSONsubElmV2 = parsedData ' Return the JSON data
End Function

Function splitDates(dateString As String, dateKey As String) As String
    Dim arrSplitDate As Variant
    Dim dayVal As String
    Dim monthVal As String
    Dim yearVal As String
    Dim rtnStr As String: rtnStr = ""
    
    arrSplitDate = Split(dateString, "/")
    
    If arrayLen(arrSplitDate) = 3 Then
        dayVal = Replace(arrSplitDate(0), """", "")
        monthVal = Replace(arrSplitDate(1), """", "")
        yearVal = Replace(arrSplitDate(2), """", "")
    End If
    
    If Len(dayVal) > 0 And Len(monthVal) > 0 And Len(yearVal) > 0 Then
        rtnStr = """" & dateKey & "_day" & """" & ":"
        rtnStr = rtnStr & """" & dayVal & """" & ","
        rtnStr = rtnStr & """" & dateKey & "_month" & """" & ":"
        rtnStr = rtnStr & """" & monthVal & """" & ","
        rtnStr = rtnStr & """" & dateKey & "_year" & """" & ":"
        rtnStr = rtnStr & """" & yearVal & """" & ","
    End If

    splitDates = rtnStr
    
End Function

Function arrayLen(arr As Variant) As Integer
    arrayLen = UBound(arr) - LBound(arr) + 1
End Function

Function mapnames(key As String)
      Dim output As String
      output = key
     'need to fill in all the name mapping below
   Select Case key
   
'  Trusts

      Case "Name of the trust (or a description it can be identified by) (Required)"
          output = "trust_name"
      Case "Date the trust was created. For example, 21/03/2007 (Required)"
          output = "creation_date"
      Case "To the best of their knowledge, does the entity have all the required information about the trust?"
          output = "unable_to_obtain_all_trust_info"

' Historical BOs

      Case "First name (also known as given name)"
          output = "forename"
      Case "Other forenames (also known as middle names)"
          output = "other_forenames"
      Case "Last name (also known as family name)"
          output = "surname"
      Case "Date they became a beneficial owner. For example, 19/07/1981"
          output = "notified_date"
      Case "Date they ceased being a beneficial owner (if relevant). For example, 21/03/2007"
          output = "ceased_date"

' Individuals

      Case "Role within the trust"
          output = "type"
      Case "First name (also known as given name)"
          output = "forename"
      Case "Other forenames (also known as middle names)"
          output = "other_forenames"
      Case "Last name (also known as family name)"
          output = "surname"
      Case "Date of birth. For example, 29/05/1973"
          output = "dob"
      Case "Nationality"
          output = "nationality"
      Case "Home address property name or number"
          output = "ura_address_premises"
      Case "Home address property name or number"
          output = "ura_address_premises"
      Case "Home address line 1"
          output = "ura_address_line_1"
      Case "Home address line 2 (optional)"
          output = "ura_address_line_2"
      Case "Home address city or town"
          output = "ura_address_locality"
      Case "Home address county, state, province or region (optional)"
          output = "ura_address_region"
      Case "Home address country"
          output = "ura_address_country"
      Case "Home address postcode or ZIP code (if applicable)"
          output = "ura_address_postal_code"


      Case "Correspondence address property name or number"
          output = "sa_address_premises"
      Case "Correspondence address line 1"
          output = "sa_address_line_1"
      Case "Correspondence address line 2 (optional)"
          output = "sa_address_line_2"
      Case "Correspondence address city or town"
          output = "sa_address_locality"
      Case "Correspondence address county, state, province or region (optional)"
          output = "sa_address_region"
      Case "Correspondence address country"
          output = "sa_address_country"
      Case "Correspondence address postcode or ZIP code (if applicable)"
          output = "sa_address_postal_code"
      Case "Date they became an interested person (for interested persons only)"
          output = "date_became_interested_person"

' Corporate Entities

      Case "Role of entity"
          output = "type"
      Case "Name of entity"
          output = "name"
      Case "Registered office addressproperty name or number"
          output = "ro_address_premises"
      Case "Registered office address property name or number"
          output = "ro_address_premises"
      Case "Registered office addressproperty name or number"
          output = "ro_address_premises"
      Case "Registered office address line 1"
          output = "ro_address_line_1"
      Case "Registered office address line 2 (optional)"
          output = "ro_address_line_2"
      Case "Registered office address city or town"
          output = "ro_address_locality"
      Case "Registered office address county, state, province or region (optional)"
          output = "ro_address_region"
      Case "Registered office address country"
          output = "ro_address_country"
      Case "Registered office address postcode or ZIP code (if applicable)"
          output = "ro_address_postal_code"
      Case "Correspondence address property name or number"
          output = "sa_address_premises"
      Case "Correspondence address line 1"
          output = "sa_address_line_1"
      Case "Correspondence address line 2 (optional)"
          output = "sa_address_line_2"
      Case "Correspondence address city or town"
          output = "sa_address_locality"
      Case "Correspondence address county, state, province or region (optional)"
          output = "sa_address_region"
      Case "Correspondence address country"
          output = "sa_address_country"
      Case "Correspondence address postcode or ZIP code (if applicable)"
          output = "sa_address_postal_code"
      Case "Country the entity was formed in"
          output = "identification_country_registration"
      Case "Governing law (this is the law it operates under)"
          output = "identification_legal_authority"
      Case "Legal form. For example, limited company."
          output = "identification_legal_form"
      Case "Name of the public register that the entity is on (if applicable)"
          output = "identification_place_registered"
      Case "Entity's registration number on the public register (if applicable)"
          output = "identification_registration_number"
      Case "Date it became an interested person (for interested persons only)"
          output = "date_became_interested_person"


        Case ""
            output = "NO_DATA"
        Case "Information shown on the public register"
            output = "NO_DATA"
        Case "None of the information you provide about the trust will be shown on the public Register of Overseas Entities. However, it may be shared with HMRC."
            output = "NO_DATA"
          
   End Select
     mapnames = output
End Function

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet7"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True