Macro to display the first and last number in a sequence of numbers increased by 1

[mir994stan]

I started a new topic because the moderator suggested it to me. You can see the old one at this link. Old topic
I have a problem with the code I am currently using to make a short string of box numbers that I use in shipping. Instead of writing all the box numbers, I write from the first to the last and the minus sign indicates all the boxes in between. The code works perfectly in most cases, but if there are several consecutive unique numbers I get an run time error 9 Subscript out of range because it cannot make a sequence with them. For each box I own I have ID numbers that increase in ascending order. If I have 50 boxes and the first one starts with the number M00100 and each subsequent number is incremented by the 1. Code instead of writing all the numbers from M00100 to M00150 it should write M00100-150 as a result. And if there is an interrupt in the array of those 50 boxes, it should mark each interrupt with // and start checking the array again. Any number that cannot be incremented by 1 must be interrupted by //

I would be very grateful if someone could help. Thanks in advance!

This is my current code:

Sub Generisi()


Dim ws As Worksheet
    Dim arr() As String, result As String, letter As String, cellValue As String, tempLastElement As String
    Dim lastColumn As Long, counter As Long
    Dim firstColumn As Integer, targetRow As Integer, i As Integer
    Set ws = Worksheets("KreirajRadniNalog")
    firstColumn = 1
    targetRow = 1
    
    lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
    ReDim arr(1 To lastColumn - firstColumn + 1)
    letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
    For i = 1 To UBound(arr)
        cellValue = ws.Cells(targetRow, i).Value
        arr(i) = Right(cellValue, Len(cellValue) - 1)
    Next i
    
    ReDim sequenceArr(1 To UBound(arr))
    sequenceArr(1) = arr(1)
    counter = 2
            For i = 1 To UBound(arr) - 1
                 If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then 
                    tempLastElement = arr(i + 1)
                    sequenceArr(counter) = tempLastElement
             Else
                    counter = counter + 1
                    sequenceArr(counter) = arr(i + 1) '<<<this line here is highlighted
                    counter = counter + 1
            End If
        
    Next
    ReDim Preserve sequenceArr(1 To counter)
    result = ""
    counter = 1
    For i = 1 To UBound(sequenceArr) - 1
        If counter > UBound(sequenceArr) Then Exit For
        If result = "" Then
            result = letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
            counter = counter + 2
        Else
            result = result & "//" & letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
            counter = counter + 2
        End If
    Next
    ws.Range("C4").Value = result
    
    
    
End Sub

 

[johnnyL]

For the people that don't like to download files:

Option Explicit

Sub Generisi()
'
    Dim arr()               As String, cellValue As String, letter As String, result As String, tempFirstElement    As String
    Dim firstColumn         As Long, lastColumn As Long
    Dim counter             As Long, i As Long, targetRow As Long, sequenceArrRowLoop  As Long
    Dim AmountOfLastDigits  As Long
    Dim ws                  As Worksheet
'
    Set ws = Worksheets("KreirajRadniNalog")                                        ' <--- Set this to the proper sheet name
    AmountOfLastDigits = 3                                                          ' <--- set This to the # of last digits to display
'
    firstColumn = 1
    targetRow = 1
'
    lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
'
    ReDim arr(1 To lastColumn - firstColumn + 1)
'
    letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
'
    For i = 1 To UBound(arr)
        cellValue = ws.Cells(targetRow, i).Value
        arr(i) = Right(cellValue, Len(cellValue) - 1)
    Next i
'
    ReDim sequenceArr(1 To UBound(arr))
'
    tempFirstElement = vbNullString                                                 ' Initialize tempFirstElement = blank
'
    counter = 1
    result = ""
'
    For i = 1 To UBound(arr) - 1                        ' 1 to 10
        If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then     '   If arr(i) value + 1 = arr(i+1) then ... ie. next slot is 1 more
            If tempFirstElement = vbNullString Then     '       If tempFirstElement hasn't been set then ...
                tempFirstElement = arr(i)               '           Save first value
            End If
        End If
'
        If CLng(arr(i)) + 1 <> CLng(arr(i + 1)) Then    '   If arr(i) value + 1 <> arr(i+1) then ... ie. next slot is not 1 more
            If tempFirstElement <> vbNullString Then     '       If tempFirstElement hasn't been set then ...
                sequenceArr(counter) = "//" & letter & tempFirstElement & "-" & Right(arr(i), AmountOfLastDigits)   ' save 'letter first element - Last 4 of this value'
                tempFirstElement = vbNullString                                             ' Erase tempFirstElement
            Else                                                                            ' Else
                sequenceArr(counter) = "//" & letter & arr(i)                               ' save Indicating break in sequence
            End If
'
            counter = counter + 1                                                       ' Increment counter
        End If
    Next
'
    If tempFirstElement <> vbNullString Then     '       If tempFirstElement hasn't been set then ...
        sequenceArr(counter) = "//" & letter & tempFirstElement & "-" & Right(arr(i), AmountOfLastDigits)   ' save 'letter first element - Last 4 of this value'
'
        tempFirstElement = vbNullString                                             ' Erase tempFirstElement
    Else                                                                            ' Else
        sequenceArr(counter) = "//" & letter & arr(i)                               ' save Indicating break in sequence
    End If
'
    result = vbNullString
'
    For sequenceArrRowLoop = 1 To counter
        result = result & sequenceArr(sequenceArrRowLoop)
    Next
'
    ws.Range("C4") = result
'
    Call NizPASTEVALUES
'
    MsgBox "Success!"
End Sub

Sub NizPASTEVALUES()
'
' NizPASTEVALUES Macro

    Range("F4").Copy
    Range("F9").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("F9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

 

[johnnyL]

Glad we could help @mir994stan.

 

[Peter_SSs]

code was altered for a solution.

That's what I was wondering. Whilst I notice that you did subsequently provide the code in the thread, please review #4 of the Forum Rules and ensure that is followed in the future.

the file I uploaded allows you to set the number of digits you want to display on the end, be it 3 or 4 or whatever.

That does not seem to be working quite correctly - see my comments/example below.

We use 3 last digits, ... But 4 digits are fine also.

Here is an alternative code that you may wish to consider. It allows you to set a minimum number of digits to show for the second number but will display more (4, 5, ..) if that helps clarify just where the change occurs.

Note that for my example data in A1:K1 the previously suggested code (with AmountOfLastDigits set to 3 produces this result in C4
//M004704998-01 //M004704401//M004705802//M004733870//M004736913-916
You will see that the first group only displays 2 digits in the second number and includes a space character after those 2 digits.

The code below produces the result in C4
//M004704998-5001//M004704401//M004705802//M004733870//M004736913-916
You will see that the last group provides the minimum number of digits for the second number but the first group shows 4 digits as that then clearly shows where it is that the first changed digit occurs.
Whether that is what you want or is any use to you I'm not sure.

Sub Generisi_v2()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, j As Long, k As Long
 
  Const MinLastDigits As Long = 3
 
  With Sheets("KreirajRadniNalog")
    a = Application.Index(Range("A1", Range("A1").End(xlToRight).Offset(, 1)).Value, 1, 0)
    a(UBound(a)) = "X0"
    ReDim b(1 To UBound(a))
    k = 1
    b(1) = a(1)
    For j = 2 To UBound(a)
      If Mid(a(j), 2) - 1 = Val(Mid(a(j - 1), 2)) Then
        i = i + 1
      Else
        If i > 0 Then b(k) = b(k) & -(Mid(b(k), 2) + i)
        k = k + 1
        If j < UBound(a) Then b(k) = a(j)
        i = 0
      End If
    Next j
    ReDim Preserve b(1 To k - 1)
    For j = 1 To UBound(b)
      If InStr(b(j), "-") > 0 Then
        Bits = Split(b(j), "-")
        k = MinLastDigits + 1
        Do Until Mid(StrReverse(Bits(1)), k, 1) = Mid(StrReverse(Bits(0)), k, 1)
          k = k + 1
        Loop
        b(j) = Bits(0) & Format(Right(Bits(1), k - 1), "-" & String(k - 1, "0"))
      End If
    Next j
    .Range("C4").Value = "//" & Join(b, "//")
  End With
  Call NizPASTEVALUES
  MsgBox "Success!"
End Sub

This was my sample data

mir994stan .xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	M004704998	M004704999	M004705000	M004705001	M004704401	M004705802	M004733870	M004736913	M004736914	M004736915	M004736916
KreirajRadniNalog

 

[johnnyL]

That's what I was wondering. Whilst I notice that you did subsequently provide the code in the thread, please review #4 of the Forum Rules and ensure that is followed in the future.

My deepest apologies to the site. Like I said, it was late when I made the post to the link. After reading through the thread again, I saw that I should post the code, if not for any other reason, links do expire.

Again my apologies.

 

[johnnyL]

That does not seem to be working quite correctly - see my comments/example below.

AmountOfLastDigits = 3        //M004689552//M004704396//M004704399-401//M004705802//M004733870//M004736913-916  Broj serije()
AmountOfLastDigits = 4        //M004689552//M004704396//M004704399-4401//M004705802//M004733870//M004736913-6916  Broj serije()
AmountOfLastDigits = 5        //M004689552//M004704396//M004704399-04401//M004705802//M004733870//M004736913-36916  Broj serije()

What part of that doesn't work?

 

[Peter_SSs]

What part of that doesn't work?

The part if the sample data happened to be as I stated.

That does not seem to be working quite correctly - see my comments/example below.

 

[johnnyL]

The part if the sample data happened to be as I stated.

You skewed your data, that is why my code didn't work properly.

You have a space at the end of 'M004705001 '

 

[johnnyL]

Simple fix for your trickery though.

Replace:

    letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
'
    For i = 1 To UBound(arr)
        cellValue = ws.Cells(targetRow, i).Value

with:

    letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
'
    For i = 1 To UBound(arr)
        cellValue = Trim(ws.Cells(targetRow, i).Value)

 

[Peter_SSs]

You skewed your data, that is why my code didn't work properly.

You have a space at the end of 'M004705001 '

Oops, sorry about that typo. I withdraw my comments.

 

[johnnyL]

No worries @Peter_SSs. I added the Trim to compensate for that in the future.