Translating string of numbers in Excel

Viewed 161

So basically I have 18 digit numbers in one column. This string represents role a given person has by this table:

100000000000000000 -> Admin

000000000010000000 -> TL

000000000100000000 -> DEV

000000010000000000 -> Viewer

000000100000000000 -> TE

000000000000100000 -> TA

By the lenght of the string I assume they are more roles, which arent important now, but might be later. Problem is, there can be any combination of roles for example:

000000010100000000 -> DEV, Viewer

000000100100000000 -> DEV, TE

100000010000100000 -> Admin, TA, Viewer

My task is to translate every string into roles.

Because I know which position represents which role, I can just search the string for "1's" and by the position of the "1's" add representative roles. Here is my problem, I have no idea if VB offers possibility to search string for multiple appearance of given char and save their relative positions. If it does, then it's only a matter of adding "if then" for each role. If it doesn't, I am lost just like now.

6 Answers

Maybe here is a starting point:

Sub Test()

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Dim str As String, Role As String
Dim arr1 As Variant, arr2 As Variant

arr1 = Array(1, 7, 8, 10, 11, 13)
arr2 = Array("Admin", "TE", "Viewer", "DEV", "TL", "TA")

str = "100000010000100000"

For x = 0 To 5
    If Mid(str, arr1(x), 1) = 1 Then Dict(arr2(x)) = 1
Next

Role = Join(Dict.Keys, ", ")

End Sub

Don't forget to include dict.RemoveAll if you intend to use this in iteration.


And for fun an Evaluate option:

Sub Test()

Dim str As String, Role As String
Dim arr1 As Variant, arr2 As Variant

str = "100000010000100000"

arr1 = Array("Admin", "TE", "Viewer", "DEV", "TL", "TA")
arr2 = Evaluate("IF(MID(""" & str & """,{1,7,8,10,11,13},1)=""1"",1,0)")

With Application
    Role = Join(Filter(.IfError(.Match(arr2, Array(0), 0), arr1), 1, False), ", ")
End With

End Sub

Here's one way to build your roles:

Private Sub Test()
   Dim role As String
   Dim roles As String
   Dim i As Integer

   role = "000000010100000000"

   For i = 1 To Len(role)
      If i = 1 And Mid(role, i, 1) = "1" Then roles = roles & "Admin, "
      If i = 7 And Mid(role, i, 1) = "1" Then roles = roles & "TE, "
      If i = 8 And Mid(role, i, 1) = "1" Then roles = roles & "Viewer, "
      If i = 10 And Mid(role, i, 1) = "1" Then roles = roles & "DEV, "
      If i = 11 And Mid(role, i, 1) = "1" Then roles = roles & "TL, "
      If i = 13 And Mid(role, i, 1) = "1" Then roles = roles & "TA, "
   Next

   MsgBox Left(roles, Len(roles) - 2)
End Sub

Another code similar to those in the answers

Sub Test()
    Dim txt As String
    Dim r As String
    Dim i As Integer
    Dim roles(1 To 13) As String

    txt = "100000010000100000"
    roles(1) = "Admin"
    roles(7) = "TE"
    roles(8) = "Viewer"
    roles(10) = "DEV"
    roles(11) = "TL"
    roles(13) = "TA"

    For i = 1 To Len(txt)
        If Mid(txt, i, 1) = "1" Then r = r & roles(i) & ", "
    Next

    Debug.Print Left(r, Len(r) - 2)
End Sub

a) Approach via Byte array

In addition to the valid solutions above and for the sake of the art another approach using a byte array:

Sub ExampleCall()
    Dim s As String: s = "100000010000100000"
    Debug.Print s & " ~> " & getRole(s)          ' ~> Admin, Viewer, TA
End Sub

Help function getRole()

Function getRole(code As String) As String
'[0]define identifying role position in code string (e.g. "100000010000100000")
    Dim roles As Variant, b() As Byte
    roles = Array(0, "Admin", 2, 3, 4, 5, 6, "TE", "Viewer", 9, "DEV", "TL", 12, "TA", 14, 15, 16, 17, 18)
'[1]assign code string to byte array (generates two elements per character)
    b = code
'[2]get the "1" positions
    Dim i As Long, role As String
    For i = LBound(b) To UBound(b) - 1 Step 2   ' check the 1st element of each char pair
        If b(i) = Asc("1") Then role = role & roles(Int(i / 2) + 1) & ", "
    Next
    role = Left(role, Len(role) - 2)
'[3]return function result
    getRole = role
End Function
 ~~~~~~~~~~~~~~~~~~~~ Edit ~~~~~~~~~~~~~~~~~~~

b) Alternative via FilterXML() (Excel vers 13+)

In order to complete the whole range of different approaches, I demonstrate how to use the WorksheetFunction FilterXML() (available in versions 13+). As there is no need to bind to a library, you may find this simple example as an alternative to dictionaries.

Sub ExampleCall2()
    Dim code As String: code = "100000010000100000"
    Debug.Print decode(code)
End Sub

Help functions decode() and XMLRole()

Function decode(code) As String
    Dim pos As Long, cnt As Long, isReady As Boolean
    ReDim tmp(1 To Len(code))
    Do While Not isReady
        pos = InStr(pos + 1, code, "1")
        If pos = 0 Then
            isReady = True
        Else
            cnt = cnt + 1: tmp(cnt) = XMLRole(pos)
        End If
    Loop
    ReDim Preserve tmp(1 To cnt)
    decode = Join(tmp, ", ")
End Function

Function XMLRole(code) As String
    Const wellformed As String = "<roles><r t='Admin'>1</r><r t='TE'>7</r><r t='Viewer'>8</r><r t='DEV'>10</r><r t='TL'>11</r><r t='TA'>13</r></roles>"
    XMLRole = WorksheetFunction.FilterXML(wellformed, "//r[.=" & code & "]/@t")
End Function

Short hints to XPath

XPath strings (here: "//r[.=" & code & "]/@t") allow to search node or attribute contents enriched by conditions (here e.g.: [.=11] pointing to a numeric content of e.g. 11) within a wellformed node structure (comparable to html). Further sub nodes or attributes are added by / to the whole term (here: attribute content of /@t (symbolising type, e.g. 'TL') after a r role node; btw the double //r indicates a role search of any r anywhere after the root element (here: roles).

Is there a necessity to do it within VBA ?

Here's a (silly?) way to pull it off just in a sheet:

Start with your values in column A. Across the columns, put your values for the individual roles ..

Here's how I set it up on my end (you can always hide rows/columns you don't need)

enter image description here

The formulas in each cell are as follows:

D4: (copied down to D6)

=SUMPRODUCT(--MID(A4,LEN(A4)+1-ROW(INDIRECT("1:"&LEN(A4))),1),(2^(ROW(INDIRECT("1:"&LEN(A4)))-1)))

E2: (copied across to J2)

=SUMPRODUCT(--MID(E1,LEN(E1)+1-ROW(INDIRECT("1:"&LEN(E1))),1),(2^(ROW(INDIRECT("1:"&LEN(E1)))-1)))

E4: (copied throughout down to J6).

=BITAND($D4,E$2)

Obviously you can combine those to eliminate extra steps (I left them in for clarity).

The funky:

=SUMPRODUCT(--MID(A4,LEN(A4)+1-ROW(INDIRECT("1:"&LEN(A4))),1),(2^(ROW(INDIRECT("1:"&LEN(A4)))-1)))

is just a tricky way of doing : BIN2DEC() on a larger value .. as per this thread:

bin2dec for numbers longer than 10 bits in excel

once you have them in decimal form, shoving them through BITAND makes it easy :)

thank you all for your help my final code looks like this:

Dim Role As String
Dim roles As String
Dim i As Integer
Dim c As Range
Dim b As Integer
b = 1
    For Each c In Range("A1", Range("A1").End(xlDown)).Rows
        Role = c.Value
        For i = 1 To Len(Role)
            If i = 1 And Mid(Role, i, 1) = "1" Then roles = roles & "Admin, "
            If i = 7 And Mid(Role, i, 1) = "1" Then roles = roles & "TE, "
            If i = 8 And Mid(Role, i, 1) = "1" Then roles = roles & "Viewer, "
            If i = 10 And Mid(Role, i, 1) = "1" Then roles = roles & "DEV, "
            If i = 11 And Mid(Role, i, 1) = "1" Then roles = roles & "TL, "
            If i = 13 And Mid(Role, i, 1) = "1" Then roles = roles & "TA, "
        Next
        Range("B" & b) = Left(roles, Len(roles) - 2)
        roles = ""
        b = b + 1
    Next c

I had a bit of problem with cycling through each cell, but that's just due to my little knowledge of AVB. It's not the prettiest code but it serves it's purpose, thanks again for helping me out :)

Related