Cannot create algorithm for a sequence in VBA

Question

After hours of work I give up as I do not see the solution anymore.

I therefore ask for your help to create following sequence:

for example given is the start code: 6D082A

The 1st position ("A") is from an array with 16 elements in this sequence: Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")

the 3rd to 5th position (082) has values from 000 to 999 the 2nd position ("D") has values from "A" to "Z" the 1st position (6) has values from 1-9

So the sequence from the example code above is: 6D082A 6D082B 6D082C .. 6D082F 6D0830 6D0831 .... 6D083F 6D0840 ... 6D999F 6E0000 .... 6Z999F 7A0000 .... 9Z999F which is the absolut last code in this sequence

Whith all the loops within the counters I am lost!

At the end the user should also enter the given first code and the number of codes he wants. My last trial was (without any start-code and any variable number of codes to create.

Sub Create_Barcodes_neu2()
Dim strErsterBC As String
Dim intRow As Integer
Dim str6Stelle As Variant
Dim intStart6  As Integer
Dim str6  As String
Dim i As Integer, ii As Integer, Index As Integer

'On Error Resume Next
Dim v As Variant
str6Stelle = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")  '16 Elemente

strErsterBC = InputBox("Enter the first Barcode.", "Barcode-Generator")
intRow = InputBox("Enter the number of barcodes to create.", "Barcode-Generator")
intStart6 = ListIndex(Mid(strErsterBC, 6, 1), str6Stelle)
str35stelle = CInt(Mid(strErsterBC, 3, 3))  'Zahl 000-999

str2stelle = Mid(strErsterBC, 2, 1)   letters A-Z
str1stelle = Left(strErsterBC, 1)

'Debug.Print str6Stelle(1); vbTab; str6Stelle(2); vbTab; str6Stelle(15); vbTab; str6Stelle(16)
For Z = 0 To 32
    ausgabe6 = i + intStart6
    i = i + 1
    ausgabe35 = str35stelle
    ausgabe2 = i3
    ausgabe1 = i4
    If i = 16 Then
       i = 0
       i2 = i2 + 1
       ausgabe35 = i2 + str35stelle
        If i2 = 999 Then
            ausgabe35 = 999
            i2 = 0
            i3 = i3 + 1

            If i3 = 26 Then
                ausgabe2 = 26
                i3 = 1
                i4 = i4 + 1

                If i4 > 9 Then
                MsgBox "Ende"
                Exit Sub
                End If

            End If

        End If

    End If

st6 = str6Stelle(ausgabe6)
st35 = Format(ausgabe35, "000")
ausgabe2 = Chr(i3)
ausgabe1 = i4
    Next Z

End Sub

Hope you can help me in my solution! Thanks a lot! Michael

Answer 1

The approach to the right algorithm is to think of a number in the following way:
Let's take a normal decimal 3-digit number. Each digit can take one element of an ordered set of symbols, 0-9.
To add 1 to this number, we exchange the rightmost symbol for the next symbol (2 becomes 3 etc.) - but if it is already the 'highest' possible symbol ("9"), then reset it to the first possible symbol ("0"), and increase the next digit to the left by one. So 129 becomes 130, and 199 has two carrying overflows and becomes 200. If we had 999 and tried and inc by one, we'd have a final overflow. Now this can be easily done with any set of symbols, and they can be completely different for every digit.

In the code, you store the symbol sets for every digit. And the "number" itself is stored as an array of indexes, pointing to which symbol is used at each position. These indexes can easily be increased. In case of an overflow for a single digit, the function IncByOne is called recursively for the next position to the left.

This is code for a class clSymbolNumber

Option Explicit

' must be a collection of arrays of strings
Public CharacterSets As Collection
' <code> must contain integers, the same number of elements as CharacterSets
' this is the indices for each digit in the corresponding character-set
Public code As Variant

Public overflowFlag As Boolean

Public Function IncByOne(Optional position As Integer = -1) As Boolean
    IncByOne = True
    If position = -1 Then position = CharacterSets.Count - 1
    ' overflow at that position?
    If code(position) = UBound(CharacterSets(position + 1)) Then
        If position = 0 Then
            overflowFlag = True
            IncByOne = False
            Exit Function
        Else
            ' reset this digit to lowest symbol
            code(position) = 0
            ' inc the position left to this
            IncByOne = IncByOne(position - 1)
            Exit Function
        End If
    Else
        code(position) = code(position) + 1
    End If
End Function

Public Sub class_initialize()
    overflowFlag = False
    Set CharacterSets = New Collection
End Sub

Public Function getCodeString() As String
    Dim i As Integer
    Dim s As String
    s = ""
    For i = 0 To UBound(code)
        s = s & CharacterSets(i + 1)(code(i))
    Next
    getCodeString = s
End Function

Testing sub in a worksheet module - this outputs all possible "numbers" with the given test data.

Sub test()
    Dim n As New clSymbolNumber
    n.CharacterSets.Add Array("1", "2", "3")
    n.CharacterSets.Add Array("a", "b")
    n.CharacterSets.Add Array("A", "B", "C", "D")
    n.CharacterSets.Add Array("1", "2", "3")
    ' start code (indexes)
    n.code = Array(0, 0, 0, 0)
    ' output all numbers until overflow
    Dim row As Long
    row = 2
    Me.Columns("A").ClearContents
    While Not n.overflowFlag
        Me.Cells(row, "A") = n.getCodeString
        n.IncByOne ' return value not immediately needed here
        row = row + 1
        DoEvents
    Wend
    MsgBox "done"
End Sub

Answer 2

I'm not sure if this is what you're looking for:

Option Explicit

Const MAX_FIRST_DEC_NUMBER As Integer = 9
Const MAX_MIDDLE_DEC_NUMBER As Integer = 999
Const MAX_LAST_HEX_NUMBER As Long= &HF

Sub Makro()

    Dim codes() As String
    Dim startCode As String
    Dim numOfBarcodes As Integer

    startCode = "0A0000" ' Starting with the "lowest" barcode

    ' Maximum number of barcodes = 4,160,000 because:
                         '0-9' *     'A-Z' *     '0-9' *     '0-9' *     '0-9' *     'A-F'
    numOfBarcodes =  CLng(10)  * CLng(26)  * CLng(10)  * CLng(10)  * CLng(10)  * CLng(16)

    codes = CreateBarcodes(startCode , numOfBarcodes)

    Dim i As Integer
    For i = 0 To numOfBarcodes - 1
        Debug.Print codes(i)
    Next

End Sub


' NOTE: Given "9Z999F" as start code will give you a numberOfBarcodes-sized array with
' one valid barcode. The rest of the array will be empty. There is room for improvement.
Function CreateBarcodes(ByVal start As String, ByVal numberOfBarcodes As Long) As String()

    ' TODO: Check if "start" is a valid barcode
    ' ...

    ' Collect barcodes:

    Dim firstDecNumber As Integer
    Dim char As Integer
    Dim middleDecNumber As Integer
    Dim lastLetter As Integer

    ReDim barcodes(0 To numberOfBarcodes - 1) As String

    For firstDecNumber = Left(start, 1) To MAX_FIRST_DEC_NUMBER Step 1

        For char = Asc(Mid(start, 2, 1)) To Asc("Z") Step 1

            For middleDecNumber = CInt(Mid(start, 3, 3)) To MAX_MIDDLE_DEC_NUMBER Step 1

                For lastLetter = CInt("&H" + Mid(start, 6, 1)) To MAX_LAST_HEX_NUMBER Step 1

                    numberOfBarcodes = numberOfBarcodes - 1

                    barcodes(numberOfBarcodes) = CStr(firstDecNumber) + Chr(char) + Format(middleDecNumber, "000") + Hex(lastLetter)

                    If numberOfBarcodes = 0 Then
                        CreateBarcodes = barcodes
                        Exit Function
                    End If

                Next

            Next

        Next

    Next

    CreateBarcodes = barcodes

End Function

Output:

9Z999F
9Z999E
9Z999D
...
1A0001
1A0000
0Z999F
0Z999E
...
0B0002
0B0001
0B0000
0A999F
0A999E
...
0A0011
0A0010
0A000F
0A000E
...
0A0003
0A0002
0A0001
0A0000