|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Take String of numbers, expand ranges, sort, then compress back into ranges
Hello, I have quite the issue I am looking to resolve. I've been searching all over the internet now for at least 3 hours with no luck.
I have a word document with thousands of little areas with seemingly random messes of numbers, such as this: Code:
11, 14, 35-37, 39-41, 49-51, 57-58, 63-64, 66, 68, 73-78, 82-87, 96, 114, 123, 17, 20-23, 25, 42, 56, 69-71, 89-91, 124, 17, 22-23, 56, 70, 89-91, 124, 20-21, 42, 69, 71, 25, 16, 18-19, 26-29, 32, 52, 72, 125, 43, 46, 53, 54, 59-62, 88, 93-94, 92, 116, 121, 122 Ideally I would just be able to select the numbers and fire the macro. I have found alphabetical sorting options, but I need numerical sorting. Thanks in advance!! |
#2
|
||||
|
||||
And what do you want to do if the same page number appears twice?
I don't have the excitement levels to code this at present but would approach this in the following way: Replace all spaces with nothing Split into an array Loop the array to convert the dashes into a series of numbers separated by commas Convert the array back into a string separated by commas Split into an array a second time and do a bubblesort to arrange them in ascending order Convert the final array back into a string separated by commas You could remove a couple of steps if you converted the initial string into an ado.recordset which simplifies the sorting requirement.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
Ah, good point. I also want to de-duplicate.
I tried to do this stuff myself, but I'm just missing knowledge of some of the fundamentals. Not really familiar with arrays. |
#4
|
|||
|
|||
Here's what I have so far:
Code:
Sub ListExpandSortDeDupCompress() Dim arrItems() As String Dim OGList As String Dim SplitList() As String Dim FinalArray() As Variant Dim Lease1 As String, Lease2 As String, InLease As Integer Dim pos As Long OGList = Selection.Text OGList = Replace(OGList, " ", "") SplitList = Split(OGList, ",") Dim i As Integer Dim j As Integer For i = LBound(SplitList) To UBound(SplitList) If InStr(1, SplitList(i), "-") Then pos = CInt(InStr(1, SplitList(i), "-") - 1) Lease1 = Left(SplitList(i), pos) Lease2 = Right(SplitList(i), Len(SplitList(i)) - pos - 1) SplitList(i) = str(Lease1) For j = Lease1 + 1 To Lease2 SplitList(i) = SplitList(i) & "," & str(j) Next j End If Next i OGList = Join(SplitList, ",") OGList = Replace(OGList, " ", "") 'MsgBox (OGList) SplitList = Split(OGList, ",") Call BubbleSort(SplitList) OGList = Join(SplitList, ",") OGList = Replace(OGList, " ", "") 'MsgBox (OGList) ReDim FinalArray(1 To 1) As Variant For i = LBound(SplitList) + 1 To UBound(SplitList) If Not IsInArray(SplitList(i), FinalArray) Then FinalArray(UBound(FinalArray)) = SplitList(i) ReDim Preserve FinalArray(1 To UBound(FinalArray) + 1) As Variant End If Next i OGList = Join(FinalArray, ",") OGList = Replace(OGList, " ", "") MsgBox (OGList) End Sub Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean IsInArray = UBound(Filter(arr, stringToBeFound)) > -1 End Function Sub BubbleSort(arr) Dim i As Integer Dim j As Integer Dim itm As Variant Dim Lease1 As String, Lease2 As String, InLease As Integer Dim pos As Integer For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If InStr(1, arr(j), "-") Then pos = InStr(1, arr(j), "-") + 1 Lease1 = CInt(Left(arr(j), pos)) Lease2 = CInt(Right(arr(j), Len(arr(j)) - pos)) End If If IsNumeric(arr(i)) And IsNumeric(arr(j)) Then If Val(arr(i)) > Val(arr(j)) Then itm = arr(i) arr(i) = arr(j) arr(j) = itm End If ElseIf arr(i) > arr(j) Then itm = arr(i) arr(i) = arr(j) arr(j) = itm End If Next j Next i End Sub First of all, THANK YOU SO MUCH! It looks like I'm really getting somewhere. The only final step I need to do is to creating the summarized ranges. I think what I need to do there is another loop of some sort that compares sequential entries. If the next entry is one step above the current entry, then the loop (or nested if/then?) would keep going until it finds either the end of the array or an entry that is not sequential. Honestly, this is probably the most daunting task for me. I'm not sure how to structure that loop/whatever. |
#5
|
|||
|
|||
I found this function. However, it isn't doing anything to my string. Is that because I need to convert my string to a long/integer array ?
Code:
Public Function RangeExtraction(AList) As String 'AList is a variant that is an array, assumed filled with numbers in ascending order Const RangeDelim = "-" 'range delimiter Dim result As String Dim InRange As Boolean Dim Posn, i, ub, lb, rangestart, rangelen As Integer result = "" 'find dimensions of AList ub = UBound(AList) lb = LBound(AList) Posn = lb While Posn < ub rangestart = Posn rangelen = 0 InRange = True 'try to extend the range While InRange rangelen = rangelen + 1 If Posn = ub Then InRange = False Else InRange = (AList(Posn + 1) = AList(Posn) + 1) Posn = Posn + 1 End If Wend If rangelen > 2 Then 'output the range if it has more than 2 elements result = result & "," & Format$(AList(rangestart)) & RangeDelim & Format$(AList(rangestart + rangelen - 1)) Else 'output the separate elements For i = rangestart To rangestart + rangelen - 1 result = result & "," & Format$(AList(i)) Next End If Posn = rangestart + rangelen Wend RangeExtraction = Mid$(result, 2) 'get rid of first comma! End Function |
#6
|
|||
|
|||
OMG... I did it.....
Code:
Sub ListExpandSortDeDupCompress() Dim arrItems() As String Dim OGList As String Dim SplitList() As String Dim FinalArray() As String Dim LongArray() As Long Dim Lease1 As String, Lease2 As String, InLease As Integer Dim pos As Long OGList = Selection.Text OGList = Replace(OGList, " ", "") SplitList = Split(OGList, ",") Dim I As Integer Dim j As Integer For I = LBound(SplitList) To UBound(SplitList) If InStr(1, SplitList(I), "-") Then pos = CInt(InStr(1, SplitList(I), "-") - 1) Lease1 = Left(SplitList(I), pos) Lease2 = Right(SplitList(I), Len(SplitList(I)) - pos - 1) SplitList(I) = Str(Lease1) For j = Lease1 + 1 To Lease2 SplitList(I) = SplitList(I) & "," & Str(j) Next j End If Next I OGList = Join(SplitList, ",") OGList = Replace(OGList, " ", "") 'MsgBox (OGList) SplitList = Split(OGList, ",") Call BubbleSort(SplitList) OGList = Join(SplitList, ",") OGList = Replace(OGList, " ", "") 'MsgBox (OGList) ReDim FinalArray(1 To 1) As String For I = LBound(SplitList) To UBound(SplitList) If Not IsInArray(SplitList(I), FinalArray) Then FinalArray(UBound(FinalArray)) = SplitList(I) ReDim Preserve FinalArray(1 To UBound(FinalArray) + 1) As String End If Next I OGList = Join(FinalArray, ",") OGList = Replace(OGList, " ", "") MsgBox (OGList) SplitList = Split(OGList, ",") LongArray = StrToLng(FinalArray) OGList = RangeExtraction(LongArray) 'OGList = Join(FinalArray, ",") 'OGList = Replace(OGList, " ", "") Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.TypeText Text:=OGList End Sub Public Function StrToLng(Str() As String) As Long() Dim I As Long Dim lng() As Long ReDim lng(LBound(Str) To UBound(Str)) 'Any Errors will result in a Zero in that element On Error Resume Next For I = LBound(Str) To UBound(Str) 'Val() is more forgiving lng(I) = Val(Str(I)) Next I 'return the resulting array StrToLng = lng 'free up memory used by dynamic array Erase lng End Function Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean IsInArray = UBound(Filter(arr, stringToBeFound)) > -1 End Function Sub BubbleSort(arr) Dim I As Integer Dim j As Integer Dim itm As Variant Dim Lease1 As String, Lease2 As String, InLease As Integer Dim pos As Integer For I = LBound(arr) To UBound(arr) - 1 For j = I + 1 To UBound(arr) If InStr(1, arr(j), "-") Then pos = InStr(1, arr(j), "-") + 1 Lease1 = CInt(Left(arr(j), pos)) Lease2 = CInt(Right(arr(j), Len(arr(j)) - pos)) End If If IsNumeric(arr(I)) And IsNumeric(arr(j)) Then If Val(arr(I)) > Val(arr(j)) Then itm = arr(I) arr(I) = arr(j) arr(j) = itm End If ElseIf arr(I) > arr(j) Then itm = arr(I) arr(I) = arr(j) arr(j) = itm End If Next j Next I End Sub Public Function RangeExtraction(AList) As String 'AList is a variant that is an array, assumed filled with numbers in ascending order Const RangeDelim = "-" 'range delimiter Dim result As String Dim InRange As Boolean Dim Posn, I, ub, lb, rangestart, rangelen As Integer result = "" 'find dimensions of AList ub = UBound(AList) lb = LBound(AList) Posn = lb While Posn < ub rangestart = Posn rangelen = 0 InRange = True 'try to extend the range While InRange rangelen = rangelen + 1 If Posn = ub Then InRange = False Else InRange = (AList(Posn + 1) = AList(Posn) + 1) Posn = Posn + 1 End If Wend If rangelen > 2 Then 'output the range if it has more than 2 elements result = result & "," & Format$(AList(rangestart)) & RangeDelim & Format$(AList(rangestart + rangelen - 1)) Else 'output the separate elements For I = rangestart To rangestart + rangelen - 1 result = result & "," & Format$(AList(I)) Next End If Posn = rangestart + rangelen Wend RangeExtraction = Mid$(result, 2) 'get rid of first comma! End Function Place that into a word VBA project. In the word document, type this: Code:
1-40,11,14,35-37,39-41,49-51,57-58,63-64,66,68,73-78,82-87,96,114,123,17,20-23,25,42,56,69-71,89-91,124,17,22-23,56,70,89-91,124,20-21,42,69,71,25,16,18-19,26-29,32,52,72,125,43,46,53,54,59-62,88,93-94,92,116,121,21-43,46,49-54,56-64,66,68-78,82-94,96,114,116,121-125 Select those numbers, then run the Macro. Output should be: Code:
1-43,46,49-54,56-64,66,68-78,82-94,96,114,116,121-125 |
#7
|
|||
|
|||
Every now and then it will fail to Deduplicate. Any pointers as to why this may be?
|
#8
|
||||
|
||||
Well done, you've come a long way on this already. Can you provide an example string that that demonstrates the problem with de-duplicating? I thought it might be how you handle the start or end of a run but couldn't replicate it with anything obvious.
As I mentioned in the first post, a recordset is an alternative way of doing this and this would allow you to make use of the SQL SELECT DISTINCT query to remove any duplicates without stepping. I will try to find some time later today to have a closer look at the code to see if there is anything to fix.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#9
|
|||
|
|||
Thanks again for your help. Honestly, I barely understand how all of these work. I just started taking everything in bite sized chunks as you suggested and using a TON of googling. I couldn't figure out the SQL or ado.recordset stuff and so I had to resort to other options.
Here is an example of a list that doesn't properly deduplicate one of the entries: 47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 47, 23, 26, 55, 51, 30, 38, 4, 35, 47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61 For some reason, 61 is repeated once. |
#10
|
|||
|
|||
Austin,
Over the years I also did tons of Goggling and have cobbled together similar processes, but none started out with a jumbled mess as you have illustrated here. I became interested when I saw you code and have been waiting anxiously for Guessed to return and show us how to use the Record. After seeing nothing further from him today, I decide to reconstruct your code in my own style (probably unique and unlike the ROW developers) and incorporate a dictionary to screen the duplicates. At the end of the day the result is the same so I hope not to imply that I think my changes makes it any better. Just showing a different approach. I don't know where he is, but Macropod (who haunts this forum) has previously posted a method as well, but I can't find it now. Code:
Option Explicit Const strSpanDelimiter = "-" Sub ListExpandSortDeDupCompress() Dim strNumberList As String Dim arrMixed() As String Dim varRawNumbers Dim arrLongs() As Long Dim strStart As String, strEnd As String Dim lngPos As Long Dim lngIndex As Integer Dim lngCount As Integer Dim oDic As Object Set oDic = CreateObject("Scripting.Dictionary") strNumberList = fcnKillWhiteSpace(Selection.Text) arrMixed = Split(strNumberList, ",") On Error GoTo Err_Handler For lngIndex = LBound(arrMixed) To UBound(arrMixed) If InStr(1, arrMixed(lngIndex), strSpanDelimiter) Then varRawNumbers = Split(arrMixed(lngIndex), strSpanDelimiter) strStart = varRawNumbers(LBound(varRawNumbers)) strEnd = varRawNumbers(UBound(varRawNumbers)) If fcnIsCountingNumber(strStart) And fcnIsCountingNumber(strEnd) Then For lngCount = strStart To strEnd If Not oDic.Exists(lngCount) Then oDic.Add lngCount, lngCount Next lngCount Else Err.Raise vbObjectError + 1 End If Else If fcnIsCountingNumber(arrMixed(lngIndex)) Then If Not oDic.Exists(CLng(arrMixed(lngIndex))) Then oDic.Add CLng(arrMixed(lngIndex)), CLng(arrMixed(lngIndex)) Else Err.Raise vbObjectError + 1 End If End If Next lngIndex On Error GoTo 0 varRawNumbers = oDic.Items BubbleSort varRawNumbers strNumberList = Join(varRawNumbers, ",") MsgBox (strNumberList) strNumberList = fcnConcatenateNumbers(varRawNumbers) strNumberList = Replace(strNumberList, ",", ", ") Selection.InsertAfter vbCr & strNumberList lbl_Exit: Exit Sub Err_Handler: If Err.Number = vbObjectError + 1 Then MsgBox "The selection contains one or more characters that prevent processing." & vbCr + vbCr _ & "The selected text must contain counting numbers (separated by commas or the span " _ & "delimiter """ & strSpanDelimiter & """) only.", _ vbInformation + vbOKOnly, "INVALID CONTENT" End If Resume lbl_Exit End Sub Function fcnKillWhiteSpace(strRaw As String) As String Dim strTemp As String strTemp = Replace(strRaw, " ", "") strTemp = Replace(strTemp, Chr(160), "") strTemp = Replace(strTemp, Chr(13), "") strTemp = Replace(strTemp, Chr(11), "") strTemp = Replace(strTemp, Chr(9), "") fcnKillWhiteSpace = strTemp lbl_Exit: Exit Function End Function Function fcnIsCountingNumber(strTest) As Boolean Dim lngTest As Long fcnIsCountingNumber = False If IsNumeric(strTest) Then lngTest = CLng(strTest) If Len(CStr(lngTest)) = Len(strTest) Then fcnIsCountingNumber = True End If lbl_Exit: Exit Function End Function Sub BubbleSort(varPassed) Dim lngIndex As Long Dim lngNextIndex As Long Dim varSwap As Variant Dim strStart As String, strEnd As String Dim lngPos As Integer For lngIndex = LBound(varPassed) To UBound(varPassed) - 1 For lngNextIndex = lngIndex + 1 To UBound(varPassed) If InStr(1, varPassed(lngNextIndex), "-") Then lngPos = InStr(1, varPassed(lngNextIndex), "-") + 1 strStart = CInt(Left(varPassed(lngNextIndex), lngPos)) strEnd = CInt(Right(varPassed(lngNextIndex), Len(varPassed(lngNextIndex)) - lngPos)) End If If IsNumeric(varPassed(lngIndex)) And IsNumeric(varPassed(lngNextIndex)) Then If Val(varPassed(lngIndex)) > Val(varPassed(lngNextIndex)) Then varSwap = varPassed(lngIndex) varPassed(lngIndex) = varPassed(lngNextIndex) varPassed(lngNextIndex) = varSwap End If ElseIf varPassed(lngIndex) > varPassed(lngNextIndex) Then varSwap = varPassed(lngIndex) varPassed(lngIndex) = varPassed(lngNextIndex) varPassed(lngNextIndex) = varSwap End If Next lngNextIndex Next lngIndex lbl_Exit: Exit Sub End Sub Public Function fcnConcatenateNumbers(varNumbers) As String 'varNumbers is a variant array of counting numbers in ascending order. Dim strTemp As String Dim lngLastNumberIndex As Long, lngElement As Long, lngIndex As Long Dim bConsecutive As Boolean Dim lngConsecutiveSpanStart As Long, lngConsecutiveCount As Long strTemp = "" lngLastNumberIndex = UBound(varNumbers) lngElement = 0 While lngElement < lngLastNumberIndex lngConsecutiveSpanStart = lngElement lngConsecutiveCount = 0 'See if adjacent elements are consecutive. Do lngConsecutiveCount = lngConsecutiveCount + 1 If lngElement = lngLastNumberIndex Then bConsecutive = False Else 'Is the next number = 1 + the current number? bConsecutive = (varNumbers(lngElement + 1) = varNumbers(lngElement) + 1) lngElement = lngElement + 1 End If Loop While bConsecutive If lngConsecutiveCount > 2 Then strTemp = strTemp & "," & Format$(varNumbers(lngConsecutiveSpanStart)) & _ strSpanDelimiter & Format$(varNumbers(lngConsecutiveSpanStart + lngConsecutiveCount - 1)) Else 'output the separate elements strTemp = strTemp & "," & Format$(varNumbers(lngConsecutiveSpanStart)) End If lngElement = lngConsecutiveSpanStart + lngConsecutiveCount Wend fcnConcatenateNumbers = Mid$(strTemp, 2) 'Get rid of first comma! lbl_Exit: Exit Function End Function Last edited by gmaxey; 07-21-2016 at 04:37 PM. |
#11
|
||||
|
||||
Austin
You are getting duplicates because of the string you are using as the input. You are selecting the text in Word and including the paragraph mark (which in this case is preceded by the number 61). Then the paragraph mark is included in all the processing so that you eliminate all excess '61's and also have a '61return'. It should be easy to remove this in your code early by including a replace line to remove Chr(13) Code:
OGList = Selection.Text OGList = Replace(OGList, " ", "") OGList = Replace(OGList, Chr(13), "") SplitList = Split(OGList, ",")
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia Last edited by Guessed; 07-21-2016 at 04:08 PM. Reason: Looked at Greg's code |
#12
|
|||
|
|||
Andrew,
I'm dealing with that at the start: strNumberList = fcnKillWhiteSpace(Selection.Text) ... which probably should include en and em spaces just to be complete. |
#13
|
|||
|
|||
Andrew,
I saw your post earlier but not your edit. Sorry for stating what you already knew. |
#14
|
||||
|
||||
I've discovered that the Recordset method doesn't actually allow use of Select Distinct in the SQL since we don't have an external table to apply the query to. A recordset does allow easy sorting though so it is still worthwhile using it for that purpose.
I've noticed that there is a flaw in the fcnConcatenateNumbers function when a run is only two numbers long. This is causing 13 to disappear from the result in the massive number set you posted above.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#15
|
|||
|
|||
Andrew,
Unfortunately we came to the same discovery. Only I thought perhaps that you had discovered something previously that did work :-( You are also correct about the flaw which Austin had right to start with. I've also beefed up the fcnKillWhiteSpace (which you like to refer to by its more colorful name). Code:
Option Explicit Const strSpanDelimiter = "-" Sub ListExpandSortDeDupCompress() Dim strNumberList As String Dim arrMixed() As String Dim varRawNumbers Dim arrLongs() As Long Dim strStart As String, strEnd As String Dim lngPos As Long Dim lngIndex As Integer Dim lngCount As Integer Dim oDic As Object Set oDic = CreateObject("Scripting.Dictionary") strNumberList = fcnKillWhiteSpace(Selection.Text) arrMixed = Split(strNumberList, ",") On Error GoTo Err_Handler For lngIndex = LBound(arrMixed) To UBound(arrMixed) If InStr(1, arrMixed(lngIndex), strSpanDelimiter) Then varRawNumbers = Split(arrMixed(lngIndex), strSpanDelimiter) strStart = varRawNumbers(LBound(varRawNumbers)) strEnd = varRawNumbers(UBound(varRawNumbers)) If fcnIsCountingNumber(strStart) And fcnIsCountingNumber(strEnd) Then For lngCount = strStart To strEnd If Not oDic.Exists(lngCount) Then oDic.Add lngCount, lngCount Next lngCount Else Err.Raise vbObjectError + 1 End If Else If fcnIsCountingNumber(arrMixed(lngIndex)) Then If Not oDic.Exists(CLng(arrMixed(lngIndex))) Then oDic.Add CLng(arrMixed(lngIndex)), CLng(arrMixed(lngIndex)) Else Err.Raise vbObjectError + 1 End If End If Next lngIndex On Error GoTo 0 varRawNumbers = oDic.Items BubbleSort varRawNumbers strNumberList = Join(varRawNumbers, ",") MsgBox (strNumberList) strNumberList = fcnConcatenateNumbers(varRawNumbers) strNumberList = Replace(strNumberList, ",", ", ") Selection.InsertAfter vbCr & strNumberList lbl_Exit: Exit Sub Err_Handler: If Err.Number = vbObjectError + 1 Then MsgBox "The selection contains one or more characters that prevent processing." & vbCr + vbCr _ & "The selected text must contain counting numbers (separated by commas or the span " _ & "delimiter """ & strSpanDelimiter & """) only.", _ vbInformation + vbOKOnly, "INVALID CONTENT" End If Resume lbl_Exit End Sub Sub Test() MsgBox fcnKillWhiteSpace("A B V") End Sub Function fcnKillWhiteSpace(strRaw As String) As String Dim arrSpaces() As String Dim lngIndex As Long Dim strTemp As String strTemp = strRaw arrSpaces = Split("9,11,13,32,160,8194,8195,8196,8197", ",") For lngIndex = 0 To UBound(arrSpaces) strTemp = Replace(strTemp, ChrW(arrSpaces(lngIndex)), "") Next lngIndex fcnKillWhiteSpace = strTemp lbl_Exit: Exit Function End Function Function fcnIsCountingNumber(strTest) As Boolean Dim lngTest As Long fcnIsCountingNumber = False If IsNumeric(strTest) Then lngTest = CLng(strTest) If Len(CStr(lngTest)) = Len(strTest) Then fcnIsCountingNumber = True End If lbl_Exit: Exit Function End Function Sub BubbleSort(varPassed) Dim lngIndex As Long Dim lngNextIndex As Long Dim varSwap As Variant Dim strStart As String, strEnd As String Dim lngPos As Integer For lngIndex = LBound(varPassed) To UBound(varPassed) - 1 For lngNextIndex = lngIndex + 1 To UBound(varPassed) If InStr(1, varPassed(lngNextIndex), "-") Then lngPos = InStr(1, varPassed(lngNextIndex), "-") + 1 strStart = CInt(Left(varPassed(lngNextIndex), lngPos)) strEnd = CInt(Right(varPassed(lngNextIndex), Len(varPassed(lngNextIndex)) - lngPos)) End If If IsNumeric(varPassed(lngIndex)) And IsNumeric(varPassed(lngNextIndex)) Then If Val(varPassed(lngIndex)) > Val(varPassed(lngNextIndex)) Then varSwap = varPassed(lngIndex) varPassed(lngIndex) = varPassed(lngNextIndex) varPassed(lngNextIndex) = varSwap End If ElseIf varPassed(lngIndex) > varPassed(lngNextIndex) Then varSwap = varPassed(lngIndex) varPassed(lngIndex) = varPassed(lngNextIndex) varPassed(lngNextIndex) = varSwap End If Next lngNextIndex Next lngIndex lbl_Exit: Exit Sub End Sub Public Function fcnConcatenateNumbers(varNumbers) As String 'varNumbers is a variant array of counting numbers in ascending order. Dim strTemp As String Dim lngLastNumberIndex As Long, lngElement As Long, lngIndex As Long Dim bConsecutive As Boolean Dim lngConsecutiveSpanStart As Long, lngConsecutiveCount As Long strTemp = "" lngLastNumberIndex = UBound(varNumbers) lngElement = 0 While lngElement <= lngLastNumberIndex lngConsecutiveSpanStart = lngElement lngConsecutiveCount = 0 'See if adjacent elements are consecutive. Do lngConsecutiveCount = lngConsecutiveCount + 1 If lngElement = lngLastNumberIndex Then bConsecutive = False Else 'Is the next number = 1 + the current number? bConsecutive = (varNumbers(lngElement + 1) = varNumbers(lngElement) + 1) lngElement = lngElement + 1 End If Loop While bConsecutive If lngConsecutiveCount > 2 Then strTemp = strTemp & "," & Format$(varNumbers(lngConsecutiveSpanStart)) & _ strSpanDelimiter & Format$(varNumbers(lngConsecutiveSpanStart + lngConsecutiveCount - 1)) Else 'output the separate elements For lngIndex = lngConsecutiveSpanStart To lngConsecutiveSpanStart + lngConsecutiveCount - 1 strTemp = strTemp & "," & Format$(varNumbers(lngIndex)) Next End If lngElement = lngConsecutiveSpanStart + lngConsecutiveCount Wend fcnConcatenateNumbers = Mid$(strTemp, 2) 'Get rid of first comma! lbl_Exit: Exit Function End Function |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Dynamic chart ranges | GlowingApple | Excel | 1 | 02-17-2016 07:18 PM |
Problem with have a chart with different data ranges | expert4knowledge | Excel | 2 | 09-09-2014 06:27 AM |
Compare content of two ranges INCLUDING FORMATTING | delasson | Word VBA | 3 | 12-10-2012 03:54 AM |
How to use named ranges in excel vba? | bosve73 | Excel Programming | 4 | 01-25-2012 09:26 AM |
Dynamic Named Ranges using text | hannu | Excel | 0 | 06-22-2010 04:42 PM |