Using VBA to increment values of letter and number (5 positions) for generating a barcode set 2

[hstacco]

I am trying to increment a barcode with values A-Z...0-9 then back to A.
Values like:
AFWK9, AFWL9, AZFL9
Would increment to:
AFWLA, AFXMA, A0FMA

I am trying to use VBA to accomplish and was able to find some code which got me to the place below however my problem is I can't figure out how to handle incrementing the Third, Second and Fourth values and how to handle when the Fourth value is a 9. I've included if statements following true to below If SFourthLetter = 9 but it's not working. If someone can get me on the right track with the Fourth letter and/or the Third letter I can figure out the rest myself. I'm a little green at VBA so please bear with me. Any help you give would be much appreciated. Thank you- Heather

Function IncrementAlpha(strIn As String) As String
'Pass this function your letter string
'Example myNewString = IncrementAlpha("ab")
'will return "ac"

Dim sAlphaBet As String
Dim sFirstLetter As String
Dim sSecondLetter As String
Dim sThirdLetter As String
Dim sFourthLetter As String
Dim sFifthLetter As String
Dim X As Variant
Dim I As Long
sFirstLetter = Left(strIn, 1)
sSecondLetter = Mid(strIn, 2, 1)
sThirdLetter = Mid(strIn, 3, 1)
sFourthLetter = Mid(strIn, 4, 1)
sFifthLetter = Mid(strIn, 5, 1)
sAlphaBet = "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,0,1,2,3,4,5,6,7,8,9"
X = Split(sAlphaBet, ",")



If sFifthLetter = "9" Then
'loop to get next first letter
For I = I To UBound(X) - 1
If X(I) = sFourthLetter Then
sFourthLetter = X(I + 1)
sFifthLetter = "A"
sThirdLetter = sThirdLetter
sSecondLetter = sSecondLetter
sFirstLetter = sFirstLetter
Exit For
End If
Next I

Else
'loop to get the next letter
For I = 0 To UBound(X) - 1
If X(I) = sFifthLetter Then
sFifthLetter = X(I + 1)
sFourthLetter = sFourthLetter
sThirdLetter = sThirdLetter
sSecondLetter = sSecondLetter
sFirstLetter = sFirstLetter
Exit For
End If

Next I
End If

IncrementAlpha = sFirstLetter & sSecondLetter & sThirdLetter & sFourthLetter & sFifthLetter
End Function

 

[Deniall]

Your examples seem to be inconsistent with your general description.[ ] The latter suggests (to me at least) that you wish to increment the right-most character by 1, then have any "overflows" ripple along from right to left as far as is necessary.

If this is correct, then the following function should do the trick once you give it a bit of a polish.

Option Explicit
Option Base 1

Function IncrBarCode(strIn As String) As String
Dim Numb As Long, I As Long, J As Long
Dim Lett As String, strOut As String
Const CharList As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
'
'  ------------------------------------------------------------------------
'
'  THIS NEEDS CHECKS ADDED.
'  »  Input string containing valid characters?
'  »  Input string not of 5 character length?
'  »  Etcetera?
'
'  THIS APPROACH WILL NOT WORK FOR INPUT STRINGS OF MORE THAN 5 CHARACTERS
'  BECAUSE THE LARGEST "LONG" INTEGER VALUE IS 2,147,483,647.
'
'  ------------------------------------------------------------------------
'
'  Form a "base 36" number from the characters in the input string.
'
Numb = 0
For I = 1 To 5
    Lett = Mid(strIn, I, 1)
    J = WorksheetFunction.Find(Lett, CharList)
    Numb = Numb * 36 + J - 1
Next I
'
'  Increment that number (allowing for overflow at the value of 36^5).
'
Numb = Numb + 1
If Numb >= 60466176 Then Numb = 0
'
'  Convert incremented number back to a new string.
'
strOut = ""
For I = 5 To 1 Step -1
    J = Numb Mod 36
    strOut = Mid(CharList, J + 1, 1) & strOut
    Numb = (Numb - J) / 36
Next I
'
IncrBarCode = strOut
End Function

If my supposition is not correct, then you need to explain your examples in a bit more detail.

 

[SkipVought]

Function IncrementAlpha(sIn As String) As String
    Dim x, i As Integer, j As Integer, iPTR(4)

    x = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,0,1,2,3,4,5,6,7,8,9", ",")
    
'assign x Pointers to sIn characters
    For i = 0 To 4
        For j = 0 To UBound(x)
            If Mid(sIn, i + 1, 1) = x(j) Then
                iPTR(i) = j
                Exit For
            End If
        Next
    Next
    
'incriment sIn pointers
    For i = 4 To 0 Step -1
        iPTR(i) = iPTR(i) + 1
        If iPTR(i) > UBound(x) Then
            iPTR(i) = 0
        Else
            Exit For
        End If
    Next
    
'assemble string
    For i = 0 To 4
        IncrementAlpha = IncrementAlpha & x(iPTR(i))
    Next
End Function

 

[Deniall]

Skip's is the better solution.[ ] The more so because it is not subject to that 2147483647 limit and therefore is able to be extended to larger strings.

 

[SkipVought]

@Deniall, the thought of base 36 (actually base is Len(sIn)-1) briefly went through my head, but the order of characters was odd. So I immediately dropped it. In this scenario, A has a base 10 value of 0 and 9 has a base 10 value of 35 by their position in the string. I wonder if by using mantissa, base and expomemt, you might be able to perform the arithmetic without conversion to base 10?

AAAAA + 1

0*36[sup]4[/sup] + 0*36[sup]3[/sup] + 0*36[sup]2[/sup] + 0*36[sup]1[/sup] + 0*36[sup]0[/sup] + 1 ==> 0*36[sup]4[/sup] + 0*36[sup]3[/sup] + 0*36[sup]2[/sup] + 0*36[sup]1[/sup] + 1*36[sup]0[/sup] ==> AAAAB

But a further thought makes me wonder if that's at all necessary, since the incriminating is all that's occurring and the incriminating is following the OP's sequence AND you're back to manipulating the pointer in the string. So using the base seems superfluous.

The fact that you pointed out, "THIS NEEDS CHECKS ADDED," reminded me that I should have added a similar caveat.

But that made me think about the flexibility of this function and I decided on these 2 changes:
1) Make the INCREMENT default to 1 but also changeable.
2) Make the LENGTH of the string to increment whatever length the user wants.

BTW, in the current 5 character configuration 99999 increments to AAAAA.

Function IncrementAlpha(sIn As String, Optional iNC As Integer = 1) As String
'this will work for any length string
'increments by 1 default be can increment be any other positive or negative integer
'might need a trap for characters other than those in the list
    Dim x, i As Integer, j As Integer, iPTR(), iLen As Integer

    iLen = Len(sIn) - 1
    ReDim iPTR(iLen)

    x = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,0,1,2,3,4,5,6,7,8,9", ",")
    
'assign x Pointers to sIn characters
    For i = 0 To iLen
        For j = 0 To UBound(x)
            If Mid(sIn, i + 1, 1) = x(j) Then
                iPTR(i) = j
                Exit For
            End If
        Next
    Next
    
'incriment sIn pointers
    For i = iLen To 0 Step -1
        iPTR(i) = iPTR(i) + iNC
        Select Case iPTR(i)
            Case Is > UBound(x)
                iPTR(i) = 0
            Case Is < 0
                iPTR(i) = UBound(x)
            Case Else
                Exit For
        End Select
    Next
    
'assemble string
    For i = 0 To iLen
        IncrementAlpha = IncrementAlpha & x(iPTR(i))
    Next
End Function

 

[Deniall]

Skip, we must have gone through similar mental processes.[ ] I also thought about variable (and negative) increments, with 1 being the default increment.[ ] Briefly.

But your later function does not work when it has to "carry" digits right-to-left because you have the line
iPTR(i) = iPTR(i) + iNC
applied at each character position.[ ] My unrefined attempt to fix this is presented below.[ ] I'm sure it can be streamlined, but I've overspent my time budget on this little problem.

Function IncrementAlpha(sIn As String, Optional iNC As Integer = 1) As String
'this will work for any length string
'increments by 1 default be can increment be any other positive or negative integer
'might need a trap for characters other than those in the list
    Dim x, i As Integer, j As Integer, iPTR(), iLen As Integer
    Dim ListLast As Integer, k As Integer

    iLen = Len(sIn) - 1
    ReDim iPTR(iLen)

    x = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,0,1,2,3,4,5,6,7,8,9", ",")
    ListLast = UBound(x)

'assign x Pointers to sIn characters
    For i = 0 To iLen
        For j = 0 To ListLast
            If Mid(sIn, i + 1, 1) = x(j) Then
                iPTR(i) = j
                Exit For
            End If
        Next
    Next

'incriment lowest-order pointer and see what flows from that
    iPTR(iLen) = iPTR(iLen) + iNC
    For i = iLen To 0 Step -1
        Select Case iPTR(i)
            Case Is > ListLast
                j = iPTR(i) Mod (ListLast + 1)
                k = Fix(iPTR(i) / (ListLast + 1))
                iPTR(i) = j
                If i <> 0 Then iPTR(i - 1) = iPTR(i - 1) + k
            Case Is < 0
                j = (ListLast) - ((-iPTR(i) - 1) Mod (ListLast + 1))
                k = Fix(((-iPTR(i)) - 1) / (ListLast + 1)) + 1
                iPTR(i) = j
                If i <> 0 Then iPTR(i - 1) = iPTR(i - 1) - k
            Case Else
                Exit For
        End Select
    Next
    
'assemble string
    For i = 0 To iLen
        IncrementAlpha = IncrementAlpha & x(iPTR(i))
    Next
End Function

I found that it was much easier to test this if I used
x = Split("0,1,2,3,4,5,6,7,8,9", ",")
instead of the full set of 36 possible characters.[ ] The mental arithmetic was much less taxing.

 

[SkipVought]

@Deniall,

But your later function does not work when it has to "carry" digits right-to-left because you have the line
iPTR(i) = iPTR(i) + iNC
applied at each character position.

Ah, but it does NOT when the pointer is any value other than a limit!

'incriment sIn pointers
    For i = iLen To 0 Step -1
        iPTR(i) = iPTR(i) + iNC
        [b]Select Case iPTR(i)
            Case Is > UBound(x)
                iPTR(i) = LBound(x)
            Case Is < LBound(x)
                iPTR(i) = UBound(x)
            [highlight #FCE94F]Case Else[/highlight]
                [highlight #FCE94F]Exit For[/highlight]
        End Select[/b]
    Next

You are making this much too difficult!
[pre]
We loop on the characters from right to left.
Increment the pointer value.
If the pointer value is at limit, "reset" the pointer value to the opposite limit.
To be more rigorous, UBound & LBound.
Else get out of the loop.
[/pre]
So if the pointer is reset, the loop goes the the NEXT character and increments it, and so on.

 

[SkipVought]

Actually, I just realized that an increment other than 1 or -1 imposes that value on all places, not just the least significant digit. And I did not account for amounts beyond the limits.

'incriment sIn pointers
    For i = iLen To 0 Step -1
        iPTR(i) = iPTR(i) + iNC
        Select Case iPTR(i)
            Case Is > UBound(x)
                iNC2 = iPTR(i) - UBound(x) - 1   'amount over the limit
                iPTR(i) = LBound(x) + iNC2
            Case Is < LBound(x)
                iNC2 = LBound(x) - iPTR(i) + 1   'amount less than limit
                iPTR(i) = UBound(x) - iNC2
            Case Else
                Exit For
        End Select
                                                 'reset increment
        Select Case iNC
           Case Is > 0: iNC = 1
           Case Is < 0: iNC = -1
        End Select
    Next

 

[hstacco]

Thank you to both of you. As I said I am green with most of this and found some existing code made a few modifications but your right it wasn't working for the 5 digits. Skip I ended up using your version of the code because to me it made a little more sense in readability. Deniall I appreciate your input and thanks for pointing out things I thank both of you so much for your help. The code works exactly as I need it to. Your both awesome in my book!
Thanks- Heather

 

[Deniall]

Skip.

If I am making things "too difficult" it is merely in my "unrefined" VBA coding.[ ] I remain convinced that all the steps I have incorporated are required to achieve full generality in the sign and size of the increment.

Your code, incorporating the change you give in your 21Jun15@14:11 post, has the following problems.[ ] For positive increments it returns #VALUE! when the increment exceeds between 1 and 2 times the "number base", ie an increment that exceeds somewhere between 36 and 72.[ ] For negative increments it gives the wrong answer as soon as any "carrying" is required, and it returns #VALUE! if it has to "carry" 2 or more.

 

[SkipVought]

@Deniall,

Thanks for the feedback.

1) Don't think I want to work thru incrementing beyond +/-36. That's my limit.

2) I corrected the negative increment logic.

'incriment sIn pointers
    For i = iLen To 0 Step -1
        iPTR(i) = iPTR(i) + iNC
        Select Case iPTR(i)
            Case Is > UBound(x)
                iNC2 = iPTR(i) - UBound(x) - 1   'amount over the limit
                iPTR(i) = LBound(x) + iNC2
            Case Is < LBound(x)
                iNC2 = LBound(x) - iPTR(i) - 1   'amount less than limit
                iPTR(i) = UBound(x) - iNC2
            Case Else
                Exit For                         'EXIT incrementing
        End Select
                                                 'reset increment
        Select Case iNC
           Case Is > 0: iNC = 1
           Case Is < 0: iNC = -1
        End Select
    Next

 

[Andrzejek]

hstacco,
Somebody here deserves a star for the help.
Please use "Great Post? Star it" link to show appreciation for the help received.

And welcome to TT

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[hstacco]

Thanks for the tip- posts starred and thanks for the welcome. I appreciate the help more than you know.

Kudos to everyone who helped!
Heather