|
|
Thread Tools | Display Modes |
#16
|
||||
|
||||
This is my effort using a Recordset to avoid the bubblesort. It is still clunky and probably no better - just a different way of doing things with arrays, recordsets and dictionaries all called up for a showing.
Code:
Option Explicit Sub ListExpandSortDeDupCompress() Dim strNumberList As String Dim arrMixed() As String, iNum As Integer Dim oRs As New ADODB.Recordset Dim oDic As Object Dim varRawNumbers As Variant Set oDic = CreateObject("Scripting.Dictionary") strNumberList = fcnKillWhiteSpace(Selection.Text) arrMixed = Split(strNumberList, ",") Set oRs = ConvertToExpandedRecordset(arrMixed) 'Sort the recordset into order and create a dictionary of unique values (in sorted order) oRs.Sort = "[FldNum]" With oRs .MoveLast If .RecordCount > 0 Then .MoveFirst While Not .EOF iNum = .Fields("FldNum").Value If Not oDic.Exists(iNum) Then oDic.Add iNum, iNum .MoveNext Wend End If End With ' varRawNumbers = oDic.Items ' strNumberList = Join(varRawNumbers, ",") ' Debug.Print strNumberList strNumberList = ConvertDict2CompressedString(oDic) Selection.InsertAfter vbCr & strNumberList End Sub Private Function ConvertToExpandedRecordset(arrValues() As String) As Recordset Dim oRs As New ADODB.Recordset, arrSpan() As String Dim lRec As Long, lCount As Long oRs.Fields.Append "FldName", adVariant, , adFldMayBeNull oRs.Fields.Append "FldNum", adInteger, , adFldMayBeNull oRs.Open For lRec = LBound(arrValues) To UBound(arrValues) If InStr(arrValues(lRec), "-") > 0 Then arrSpan = Split(arrValues(lRec), "-") For lCount = CLng(arrSpan(0)) To CLng(arrSpan(1)) oRs.AddNew oRs("FldName").Value = lCount oRs("FldNum").Value = lCount oRs.Update Next lCount Else oRs.AddNew oRs("FldName").Value = arrValues(lRec) oRs("FldNum").Value = CLng(arrValues(lRec)) oRs.Update End If Next lRec Set ConvertToExpandedRecordset = oRs End Function 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 ConvertDict2CompressedString(oDic) As String Dim v As Variant, bConsecutive As Boolean, sRun As String Dim iStartRun As Integer, iEndRun As Integer, sTemp As String For Each v In oDic.Keys If oDic.Exists(v + 1) Then If Not bConsecutive Then 'first entry in a run iStartRun = v bConsecutive = True 'sRun = iStartRun & "," & v ElseIf v - iStartRun = 1 Then 'second entry in a run sRun = iStartRun & "," & v Else 'run has 3+ entries iEndRun = v sRun = iStartRun & "-" & v End If Else If Not bConsecutive Then sRun = v sTemp = sTemp & "," & sRun ElseIf v - iStartRun = 1 Then sRun = iStartRun & "," & v sTemp = sTemp & "," & sRun Else sTemp = sTemp & "," & iStartRun & "-" & v End If bConsecutive = False End If Next Debug.Print sTemp sTemp = Mid(sTemp, 2) ConvertDict2CompressedString = Replace(sTemp, ",", ", ") End Function
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#17
|
||||
|
||||
Quote:
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#18
|
|||
|
|||
Andrew,
Except for the variable names (because I'm the odd ball) I really like your ConvertDict2CompressedString function. Does the same thing but clean and easier for me to follow. Since the dictionary is established with late binding, I think I would do the same with the Record Set. Also there is no error handling to deal with 1, 2, buckle your shoe, 3, 4 or 1, 1.2, $3.00, 4, 5 etc. I has been an interesting thread. Thanks all! |
#19
|
|||
|
|||
All:
Thank you so much for your help on all of this. Very helpful and interesting to see other people's much cleaner and more organized redo of my code. Much easier to understand what's going on. I came across another question about this process. What if I wanted to specify a range of numbers, say "20-30," that needed to be adjusted up or down by 1 or 2? In other words, once the numbers are expanded, correct all numbers within a defined range up or down by a specified amount (20 should become 22, 21 should become 23, and so on), and then proceed to sort and compress those numbers. Seems like this should be a fairly simple operation that could be inserted after the gmaxey's bubblesort expands the strSpanDelimiter, but I'm not sure where to add the operation. |
#20
|
||||
|
||||
Here's my implementation. I've incorporated two functions I've created for other purposes (one to expand number ranges like 11-15, the other the contract number ranges like 11, 12, 13, 14, 15).
Code:
Sub Demo() Dim StrIn As String, StrOut As String, NumArr(), i As Long, j As Long StrIn = "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" StrIn = "," & Replace(ParseNumberString(StrIn, ", ", "-"), " ", "") & "," i = UBound(Split(StrIn, ",")) Do While UBound(Split(StrIn, ",")) > 1 StrOut = StrOut & " " & Split(StrIn, ",")(1) StrIn = Replace(StrIn, "," & Split(StrIn, ",")(1) & ",", ",") StrIn = Replace(StrIn, "," & Split(StrIn, ",")(1) & ",", ",") Loop StrIn = Trim(StrOut) i = UBound(Split(StrIn, " ")) ReDim NumArr(i) For j = 0 To i NumArr(j) = Split(StrIn, " ")(j) Next WordBasic.SortArray NumArr() StrOut = Join(NumArr(), ",") MsgBox ParseNumSeq(StrOut, "&") End Sub Function ParseNumberString(StrIn As String, strSS, strGS) Dim i As Long, j As Long, StrTmp As String, Arr As Variant Arr = Filter(Split(StrIn, strSS), strGS) For i = 0 To UBound(Arr) StrTmp = "" For j = Val(Arr(i)) To Split(Arr(i), strGS)(1) StrTmp = StrTmp & strSS & j Next StrIn = Replace(StrIn, Arr(i), Mid(StrTmp, 2)) Next ParseNumberString = StrIn End Function Function ParseNumSeq(StrNums 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. ' The separator for the last sequence can be set via the StrEnd variable. Dim ArrTmp(), i As Integer, j As Integer, k As Integer ReDim ArrTmp(UBound(Split(StrNums, ","))) For i = 0 To UBound(Split(StrNums, ",")) ArrTmp(i) = Split(StrNums, ",")(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 StrNums = Join(ArrTmp, ",") StrNums = Replace(Replace(Replace(StrNums, ",,", " "), ", ", " "), " ,", " ") While InStr(StrNums, " ") StrNums = Replace(StrNums, " ", " ") Wend StrNums = Replace(Replace(StrNums, " ", "-"), ",", ", ") If StrEnd <> "" Then i = InStrRev(StrNums, ",") If i > 0 Then StrNums = Left(StrNums, i - 1) & Replace(StrNums, ",", " " & Trim(StrEnd), i) End If End If ParseNumSeq = StrNums End Function Code:
For i = 29 To 20 Step -1 StrIn = Replace(StrIn, "," & i & ",", "," & i + 1 & ",") Next StrIn = "," & Replace(ParseNumberString(StrIn, ", ", "-"), " ", "") & "," to decrement them instead you'd use code like: Code:
For i = 21 To 30 StrIn = Replace(StrIn, "," & i & ",", "," & i - 1 & ",") Next
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
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 |