Concatenate Numbers

[gmaxey]

Well I think that is the term. Paul, as the wizard in this area, or anyone else I hope you can help.

I've cobbled together some code to attempt to turn strings like 1, 2, 3, 4, 5, 10 into 1-5, 10. Can you advise if there is a better way? Thanks.


Sub TestProc()
MsgBox ConconcateNumbers("1, 2, 3, 4, 5, 7, 9, 12, 13, 14, 15, 16, 20, 21")
End Sub
Function ConconcateNumbers(ByRef strProcess As String) As String
Dim strNums() As String
Dim i As Long, j As Long
strNums() = Split(Replace(strProcess, " ", ""), ",")
strProcess = strNums(0)
For i = 1 To UBound(strNums)
On Error GoTo Err_Scope
If strNums(i) = strNums(i - 1) + 1 And strNums(i) = strNums(i + 1) - 1 Then
If Not Right(strProcess, 1) = "-" Then
strProcess = strProcess & "-"
Else
If strNums(i + 1) = strNums(i + 1 - 1) + 1 And strNums(i) = strNums(i + 1 + 1) - 1 Then
strProcess = strProcess & strNums(i)
End If
End If
Else
If Right(strProcess, 1) = "-" Then
strProcess = strProcess & strNums(i)
Else
strProcess = strProcess & ", " & strNums(i)
End If
End If
Err_Rentry:
Next i
lbl_Exit:
ConconcateNumbers = strProcess
Exit Function
Err_Scope:
If Right(strProcess, 1) = "-" Then
If strNums(i) < strNums(UBound(strNums)) - 1 Then
strProcess = strProcess & strNums(i)
Resume Err_Rentry
Else
strProcess = strProcess & strNums(UBound(strNums))
End If
Else
strProcess = strProcess & ", " & strNums(i)
End If
Resume lbl_Exit
End Function

[fumei]

Greg, AFAIK there is only brute force testing each trailing character, which you have done nicely. I am going to carefully step through it, but it sure looks good to me.

Newbies and even those quite familiar with VBA, examine Greg's use of the sub-routine Err_Scope.

It may be nice to add anothert level of "error" trapping. If you add an alpha character to the mix, say the "h" in:

MsgBox ConconcateNumbers("1, 2, h3, 4, 5, 7, 9, 12, 13, 14, 15, 16, 20, 21")

It does not make any comment. It just returns:

1,2

and ("1, 2, 3, 4, 5, 7, 9, 12, 13, h14, 15, 16, 20, 21") returns:

1-5,7,9,12,13

Everything after the alpha character is ignored. I am not sure what the final objective. Say in the h14 example, would you want to just reject THAT, and end up with:

1-5,7,9,12,13,15,16,20,21

???????

[fumei]

It is interesting that:

"1, 2, 3, 4, 5ggg, 7, 9, 12, 13, h14, 15, 16, 20, 21"

returns

1-3, 4

even though 4 DOES follow in sequence to 1,2,3

[macropod]

The following is a function I developed to convert multiple sequences of 3 or more consecutive page numbers (hence the StrPages variable) in a list to a string consisting of the first & last numbers separated by a hyphen. The function includes some optional code to replace the final comma with, say, '&' or 'and'.
Function ParsePageRefs(StrPages As String , Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrPages, ",")))
For i = 0 To UBound(Split(StrPages, ","))
ArrTmp(i) = Split(StrPages, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
i = j - 1
End If
Next
StrPages = Replace(Replace(Replace(Replace(Replace(Join(ArrTmp, ","), ",,", " "), " ,", " "), " ", " "), " ", "-"), ",", ", ")
If StrEnd <> "" Then
i = InStrRev(StrPages, ",")
If i > 0 Then
StrPages = Left(StrPages, i - 1) & Replace(StrPages, ",", " " & Trim(StrEnd), i)
End If
End If
ParsePageRefs = StrPages
End Function
The following macro demonstrates the function.
Sub Test()
Dim StrPages As String
StrPages = "1,2,3,4,5,7,8,9,11,13,14,15,16"
MsgBox ParsePageRefs(StrPages, "&")
End Sub

[gmaxey]

Paul, Gerry

Thanks for your interest and input to this thread.

I had made several attempts at something like Paul provided but the clumps of hair and bloody scalp was piling up so I rerouted to the code I posted. Paul your code gave me some ideas which are provided below.

One problem I encountered with Paul's code was with long sequences of continuous numbers (e.g, 1,2,3,4,5,6,10,30,31,32,33,34). When running the code if there were more than four (I think) then I was get multiple "-" in the string. Other than continuing to add to the Replace(Replace), I devised a different method that at least appears to work. I also added some more validation of the string passed.

Function ParseNumbers(strNums As String, Optional strFinalSep As String) As String
'Converts multiple sequences of 3 or more consecutive numbers in a list to a string
'consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp() As String, strValid As String
Dim lngIndex As Long, lngAdv As Long, lngOffset As Long
'Create array of numbers passed.
ArrTmp = Split(Replace(strNums, " ", ""), ",")

'Validate string passed.
strValid = Join(ArrTmp, "")
'Does string consist of whole numbers only?
If InStr(strValid, ".") > 0 Or InStr(strValid, "$") > 0 Or Not IsNumeric(strValid) Then
ParseNumbers = "Invalid string. The string passed must be whole numbers only."
Exit Function
End If
'Are whole numbers increasing in sequence?
For lngIndex = 0 To UBound(ArrTmp) - 1
If CLng(ArrTmp(lngIndex)) >= CLng(ArrTmp(lngIndex + 1)) Then
ParseNumbers = "Invalid string. The string passed must be whole numbers increasing in sequence."
Exit Function
End If
Next lngIndex

'Parse each number except the last number.
For lngIndex = 0 To UBound(ArrTmp) - 1
lngOffset = 2
For lngAdv = lngIndex + 2 To UBound(ArrTmp)
'Does the offset number element match the next expected number in a continous sequence?
If ArrTmp(lngIndex) + lngOffset <> ArrTmp(lngAdv) Then
Exit For
Else
ArrTmp(lngAdv - 1) = ""
lngOffset = lngOffset + 1
End If
Next
'Revise indexing.
lngIndex = lngAdv - 2
Next
'Format the output string.
strNums = ""
For lngIndex = 0 To UBound(ArrTmp)
If ArrTmp(lngIndex) <> "" Then
'Does this number end a conconated number sequence?
If Right(strNums, 1) = "-" Then
strNums = strNums & ArrTmp(lngIndex)
Else
On Error Resume Next
If ArrTmp(lngIndex) - 1 <> ArrTmp(lngIndex - 1) Then
'Is this the first pass? Yes, then expect error due to scope conflict.
If Err.Number <> 0 Then
'Define first number.
strNums = strNums & ArrTmp(lngIndex)
Else
'Start new sequence.
strNums = strNums & ", " & ArrTmp(lngIndex)
End If
Else
'Two numbers in sequence. List both.
strNums = strNums & ", " & ArrTmp(lngIndex)
End If
End If
Else
If Not Right(strNums, 1) = "-" Then
'Flag in conconated number sequence.
strNums = strNums & "-"
End If
End If
Next lngIndex

'Format optional final separator.
If strFinalSep <> "" Then
lngIndex = InStrRev(strNums, ",")
If lngIndex > 0 Then
strNums = Left(strNums, lngIndex - 1) & Replace(strNums, ",", " " & Trim(strFinalSep), lngIndex)
End If
End If
ParseNumbers = strNums
End Function

Tested with:

Sub Test()
Dim StrPages As String
StrPages = "9, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 30"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,2,3,5,6,7,8,10,11,17,18,19,20,21,22,23,30"
MsgBox ParseNumbers(StrPages, " and ")
StrPages = "1,2,4,5,6"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,2,3,4,5"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,2h,3,4,5"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,2.5,3,4,5"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,$2,3,4,5"
MsgBox ParseNumbers(StrPages, "")
StrPages = "1,2,4,5,5"
MsgBox ParseNumbers(StrPages, "")
End Sub

[macropod]

Hi Greg,

I hadn't noticed the '--' occurrences before, probably because I hadn't tested with long-enough sequences. The following update should take care of that:
Function ParsePageRefs(StrPages As String, Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrPages, ",")))
For i = 0 To UBound(Split(StrPages, ","))
ArrTmp(i) = Split(StrPages, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
i = j - 2
End If
Next
StrPages = Join(ArrTmp, ",")
StrPages = Replace(Replace(Replace(StrPages, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrPages, " ")
StrPages = Replace(StrPages, " ", " ")
Wend
StrPages = Replace(Replace(StrPages, " ", "-"), ",", ", ")
If StrEnd <> "" Then
i = InStrRev(StrPages, ",")
If i > 0 Then
StrPages = Left(StrPages, i - 1) & Replace(StrPages, ",", " " & Trim(StrEnd), i)
End If
End If
ParsePageRefs = StrPages
End Function

[gmaxey]

Paul,

Yes that seems to work just as well as my version. At least with the limited test strings. Do you even own a sledgehammer? You have a gift for driving railroad spikes with a tack hammer. Well as least there are two working versions posted here.

The purpose behind this exercise was to figure out a way to concenate a series of rather odd sequence fields nested in a content control. If you are interested here is the code I used:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oCC As ContentControl
Dim strNums As String
Dim arrParsedNums() As String
Dim i As Long
Dim oFld As Word.Field
Set oCC = Selection.ContentControls(1)
strNums = oCC.Range.Text
For i = 1 To Len(strNums)
If IsNumeric(Mid(strNums, i, 1)) Then
strNums = Right(strNums, Len(strNums) - i + 1)
Exit For
End If
Next i
'This gives us the number string
Debug.Print strNums
strNums = ParseNumbers(strNums)
Debug.Print strNums
arrParsedNums = Split(strNums, ",")
i = 0
Dim oRng As Word.Range
For Each oFld In oCC.Range.Fields
If oFld.Type = wdFieldSequence Then
oFld.Code.Text = Replace(oFld.Code.Text, "\* MERGEFORMAT", "")
oFld.Code.Text = Replace(oFld.Code.Text, "\* MergeFormat", "")
oFld.Code.Text = Replace(oFld.Code.Text, " ", " ")
oFld.Code.Text = Replace(oFld.Code.Text, " ", " ")
If arrParsedNums(i) = "X" Then
oFld.Code.Text = oFld.Code.Text & "\h"
'oFld Update triggers CC entry event
ActiveDocument.Fields.Update
End If
i = i + 1
End If
Next oFld
For i = 2 To oCC.Range.Characters.count
If IsNumeric(oCC.Range.Characters(i)) Then
Set oRng = oCC.Range.Characters(i)
Exit For
End If
Next i
Do Until oRng.End = oCC.Range.End
oRng.Move wdCharacter, 1
Select Case True
Case oRng.Characters(1) = "," And oRng.Characters(1).Next = ","
oRng.Characters(1) = "-"
Case oRng.Characters(1).Previous = "-" And oRng.Characters(1) = ","
oRng.Characters(1).Delete
End Select
Loop
For Each oFld In oCC.Range.Fields
If Trim(oFld.Code.Text) = "Macrobutton PT_Haz [Edit]" Then
oFld.Code.Text = "Macrobutton PT_Haz"
End If
Exit For
Next

End Sub
Function ParseNumbers(strNums As String) As String
'Converts multiple sequences of 3 or more consecutive numbers in a list to a string
'consisting of the first & last numbers separated by a hyphen.
Dim arrNums() As String, strValid As String
Dim lngIndex As Long, lngAdv As Long, lngOffset As Long
'Create array of numbers passed.
arrNums = Split(Replace(strNums, " ", ""), ",")
'Parse each number except the last number.
For lngIndex = 0 To UBound(arrNums) - 1
lngOffset = 2
For lngAdv = lngIndex + 2 To UBound(arrNums)
'Does the offset number element match the next expected number in a continous sequence?
If arrNums(lngIndex) + lngOffset <> arrNums(lngAdv) Then
Exit For
Else
arrNums(lngAdv - 1) = "X"
lngOffset = lngOffset + 1
End If
Next
'Revise indexing.
lngIndex = lngAdv - 2
Next
strNums = ""
For lngIndex = 0 To UBound(arrNums)
strNums = strNums & "," & arrNums(lngIndex)
Next lngIndex
strNums = Right(strNums, Len(strNums) - 1)
ParseNumbers = strNums
End Function

The expanded field code in the CC might look like this:


{ Macrobutton PT_Haz}/ { SEQ TableHazard HazardTableUnique1 },{ SEQ TableHazard HazardTableUnique2},{ SEQ TableHazard HazardTableUnique3}

the result will look like this:
{MacroButton PT_Haz}/ { SEQ TableHazard HazardTableUnique1 }-{ SEQ TableHazard HazardTableUnique2 \h}{ SEQ TableHazard HazardTableUnique3}







Thanks again for you interest!

[macropod]

Do you even own a sledgehammer? You have a gift for driving railroad spikes with a tack hammer.
No, but I do own a crowbar ... not so sure about the 'gift', though - I don't own a tack hammer either.

PS: I've streamlined the code a bit since the initial post.

[gmaxey]

Well you've "tacked" a plenty of fine code here and elsewhere so let me say that you are very handy with that crowbar.

[gmaxey]

Taking back the other direction:

Function ExpandTruncNums(ByRef strTruncNums As String) As String
'A basic Word macro coded by Greg Maxey
Dim strNumList, lngStart As Long, lngEnd As Long
Dim arrNums() As String
Dim i As Long, j As Long
strTruncNums = Replace(Replace(strTruncNums, " ", ""), "and", ",")
arrNums() = Split(strTruncNums, ",")
For i = 0 To UBound(arrNums)
Select Case True
Case InStr(arrNums(i), "-") > 0
lngStart = VBA.Left(arrNums(i), InStr(arrNums(i), "-") - 1)
lngEnd = VBA.Mid(arrNums(i), InStr(arrNums(i), "-") + 1, Len(arrNums(i)) - InStr(arrNums(i), "-"))
For j = lngStart To lngEnd
strNumList = strNumList & j & ", "
Next j
Debug.Print arrNums(i)
Case Else
strNumList = strNumList & arrNums(i) & ", "
End Select
Next i
ExpandTruncNums = Left(strNumList, Len(strNumList) - 2)
lbl_Exit:
Exit Function
End Function

[macropod]

Wouldn't it have been easier to not do the previous concatenation? :whip

[gmaxey]

But not as much fun!