Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #16  
Old 07-22-2016, 12:48 AM
Guessed's Avatar
Guessed Guessed is online now Windows 10 Office 2013
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 956
Guessed is on a distinguished road
Default

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
Reply With Quote
  #17  
Old 07-22-2016, 12:49 AM
Guessed's Avatar
Guessed Guessed is online now Windows 10 Office 2013
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 956
Guessed is on a distinguished road
Default

Quote:
I've also beefed up the fcnKillWhiteSpace (which you like to refer to by its more colorful name).
Its always best to be grammatically correct
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #18  
Old 07-22-2016, 11:38 AM
gmaxey gmaxey is offline Windows 7 32bit Office 2010 (Version 14.0)
Word MVP 2003-2009
 
Join Date: May 2010
Location: Marble, NC
Posts: 795
gmaxey will become famous soon enough
Default

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!
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #19  
Old 08-22-2016, 03:11 PM
AustinBrister AustinBrister is offline Windows 7 64bit Office 2013
Novice
 
Join Date: May 2015
Posts: 16
AustinBrister is on a distinguished road
Default

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.
Reply With Quote
  #20  
Old 08-22-2016, 05:18 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,671
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
AustinBrister: If you want to increment a certain series of numbers that might be included in the data, you could insert code like:
Code:
For i = 29 To 20 Step -1
  StrIn = Replace(StrIn, "," & i & ",", "," & i + 1 & ",")
Next
after:
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
[MS MVP - Word]
Reply With Quote
Reply

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


All times are GMT -7. The time now is 06:31 PM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft