Solved

Truncate all numbers with 3 decimal places to 2 decimal places & highlight changed numbers in colour

Posted on 2014-03-25
6
581 Views
Last Modified: 2014-03-27
I've inherited a large, somewhat poorly formatted, spreadsheet of communication frequencies. I am looking for a macro that will:

1. Truncate (not round) all numbers that have 3 decimal places down to 2 decimal places
2. If the 3-decimal number ends in "00", then number to be truncated down to 1 decimal place (ie., 135.100 becomes 135.1)
3. All numbers that change to turn the color red.

The cells can contain an alpha numeric mix and often have multiple entries in one cell using line breaks. The line breaks need to be maintained.

Here is a current and revised cell example:

Current cell format:
YYYYY Townname 126.425
250.156
98.100

Revised cell format:
YYYYY Townname 126.42
250.15
98.1

Thanks!
Andrea
0
Comment
Question by:Andreamary
  • 2
  • 2
  • 2
6 Comments
 
LVL 39

Assisted Solution

by:nutsch
nutsch earned 100 total points
ID: 39953720
Here's the code for that, minus the red font part:

Sub Cleanup()

Dim lLastRow As Long, lRowLoop As Long, dbTemp As Double, sTemp As String
Dim sFound As String, lPos As Long, lNumChar As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

For lRowLoop = 1 To lLastRow
    Do While RegExpFind(Cells(lRowLoop, 1), "\d+\.\d\d\d+", 1) <> ""
        sFound = RegExpFind(Cells(lRowLoop, 1), "\d+\.\d\d\d+", lLoop)
        dbTemp = Application.WorksheetFunction.RoundDown(CDbl(sFound), 2)
        
        sTemp = Format(dbTemp, "0.00")
        sTemp = IIf(Right(sTemp, 1) = 0, Left(sTemp, Len(sTemp) - 1), sTemp)
        
        lPos = InStr(Cells(lRowLoop, 1), sFound)
        lNumChar = Len(sTemp)
        
        Cells(lRowLoop, 1).Value = Replace(Cells(lRowLoop, 1).Value, sFound, sTemp)
    
      '  Cells(lRowLoop, 1).Characters(Start:=lPos, Length:=lNumChar).Font.Color = -16776961
            
    Loop
Next lRowLoop
    

End Sub

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
    Optional MatchCase As Boolean = True, Optional ReturnType As Long = 0, _
    Optional MultiLine As Boolean = False)
    
    ' Function written by Patrick G. Matthews.  You may use and distribute this code freely,
    ' as long as you properly credit and attribute authorship and the URL of where you
    ' found the code
    
    ' This function relies on the VBScript version of Regular Expressions, and thus some of
    ' the functionality available in Perl and/or .Net may not be available.  The full extent
    ' of what functionality will be available on any given computer is based on which version
    ' of the VBScript runtime is installed on that computer
    
    ' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
    ' pattern (PatternStr).  Use Pos to indicate which match you want:
    ' Pos omitted               : function returns a zero-based array of all matches
    ' Pos = 1                   : the first match
    ' Pos = 2                   : the second match
    ' Pos = <positive integer>  : the Nth match
    ' Pos = 0                   : the last match
    ' Pos = -1                  : the last match
    ' Pos = -2                  : the 2nd to last match
    ' Pos = <negative integer>  : the Nth to last match
    ' If Pos is non-numeric, or if the absolute value of Pos is greater than the number of
    ' matches, the function returns an empty string.  If no match is found, the function returns
    ' an empty string.  (Earlier versions of this code used zero for the last match; this is
    ' retained for backward compatibility)
    
    ' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
    ' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).
    
    ' ReturnType indicates what information you want to return:
    ' ReturnType = 0            : the matched values
    ' ReturnType = 1            : the starting character positions for the matched values
    ' ReturnType = 2            : the lengths of the matched values
    
    ' If MultiLine = False, the ^ and $ match the beginning and end of input, respectively.  If
    ' MultiLine = True, then ^ and $ match the beginning and end of each line (as demarcated by
    ' new line characters) in the input string
    
    ' If you use this function in Excel, you can use range references for any of the arguments.
    ' If you use this in Excel and return the full array, make sure to set up the formula as an
    ' array formula.  If you need the array formula to go down a column, use TRANSPOSE()
    
    ' Note: RegExp counts the character positions for the Match.FirstIndex property as starting
    ' at zero.  Since VB6 and VBA has strings starting at position 1, I have added one to make
    ' the character positions conform to VBA/VB6 expectations
    
    ' Normally as an object variable I would set the RegX variable to Nothing; however, in cases
    ' where a large number of calls to this function are made, making RegX a static variable that
    ' preserves its state in between calls significantly improves performance
    
    Static RegX As Object
    Dim TheMatches As Object
    Dim Answer()
    Dim Counter As Long
    
    ' Evaluate Pos.  If it is there, it must be numeric and converted to Long
    
    If Not IsMissing(Pos) Then
        If Not IsNumeric(Pos) Then
            RegExpFind = ""
            Exit Function
        Else
            Pos = CLng(Pos)
        End If
    End If
    
    ' Evaluate ReturnType
    
    If ReturnType < 0 Or ReturnType > 2 Then
        RegExpFind = ""
        Exit Function
    End If
    
    ' Create instance of RegExp object if needed, and set properties
    
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = True
        .IgnoreCase = Not MatchCase
        .MultiLine = MultiLine
    End With
        
    ' Test to see if there are any matches
    
    If RegX.Test(LookIn) Then
        
        ' Run RegExp to get the matches, which are returned as a zero-based collection
        
        Set TheMatches = RegX.Execute(LookIn)
        
        ' Test to see if Pos is negative, which indicates the user wants the Nth to last
        ' match.  If it is, then based on the number of matches convert Pos to a positive
        ' number, or zero for the last match
        
        If Not IsMissing(Pos) Then
            If Pos < 0 Then
                If Pos = -1 Then
                    Pos = 0
                Else
                    
                    ' If Abs(Pos) > number of matches, then the Nth to last match does not
                    ' exist.  Return a zero-length string
                    
                    If Abs(Pos) <= TheMatches.Count Then
                        Pos = TheMatches.Count + Pos + 1
                    Else
                        RegExpFind = ""
                        GoTo Cleanup
                    End If
                End If
            End If
        End If
        
        ' If Pos is missing, user wants array of all matches.  Build it and assign it as the
        ' function's return value
        
        If IsMissing(Pos) Then
            ReDim Answer(0 To TheMatches.Count - 1)
            For Counter = 0 To UBound(Answer)
                Select Case ReturnType
                    Case 0: Answer(Counter) = TheMatches(Counter)
                    Case 1: Answer(Counter) = TheMatches(Counter).FirstIndex + 1
                    Case 2: Answer(Counter) = TheMatches(Counter).Length
                End Select
            Next
            RegExpFind = Answer
        
        ' User wanted the Nth match (or last match, if Pos = 0).  Get the Nth value, if possible
        
        Else
            Select Case Pos
                Case 0                          ' Last match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(TheMatches.Count - 1)
                        Case 1: RegExpFind = TheMatches(TheMatches.Count - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(TheMatches.Count - 1).Length
                    End Select
                Case 1 To TheMatches.Count      ' Nth match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(Pos - 1)
                        Case 1: RegExpFind = TheMatches(Pos - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(Pos - 1).Length
                    End Select
                Case Else                       ' Invalid item number
                    RegExpFind = ""
            End Select
        End If
    
    ' If there are no matches, return empty string
    
    Else
        RegExpFind = ""
    End If
    
Cleanup:
    ' Release object variables
    
    Set TheMatches = Nothing
    
End Function

Open in new window

0
 

Author Comment

by:Andreamary
ID: 39953862
I don't have a lot of macro experience so if you can just let me know if I create one macro for the above and paste the code into it, or do I create more than one macro?

Thanks for your patience!
Andrea
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39953866
Hi,

my version without the red formatting
Sub Macro()
Dim c As Range
For Each c In ActiveSheet.UsedRange
    arrLines = Split(c, vbLf)
     For Each Ln In arrLines
        arrWrds = Split(Ln, " ")
        For Each wrd In arrWrds
            If IsNumeric(wrd) Then
                dblWrd = CDbl(wrd)
                Rest = dblWrd - Int(dblWrd)
                If Rest <> 0 Then ' not integer
                    Number = Fix(dblWrd * 100) / 100
                    NewWrd = Format(Number, "#.0#")
                    MsgBox NewWrd
                Else
                    NewWrd = wrd
                End If
            Else
                NewWrd = wrd
            End If
        NewLine = NewLine & NewWrd & " "
        Next
    NewLine = Left(NewLine, Len(NewLine) - 1)
    Result = Result & NewLine & vbLf
    NewLine = ""
    Next
c.Value = Left(Result, Len(Result) - 1)
Result = ""
Next
End Sub

Open in new window

Regards
0
What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

 
LVL 39

Expert Comment

by:nutsch
ID: 39953873
Go into the visual basic editor (alt+F11), select your workbook and choose Insert \ Module from the top menu bar.

Copy all the code in the module.

Run by using Alt+F8 from your worksheet, or F5 from VB Editor.

The code will run on all cells in column A.

I'd recommend saving a backup copy of your workbook before launching the macro, macros cannot be undone generally.

Thomas
0
 
LVL 48

Accepted Solution

by:
Rgonzo1971 earned 400 total points
ID: 39953960
Hi,

The code here Format in red the numbers that have been changed
EDITED$
corrected code
Format in red only the numbers that have been changed
Sub Macro()
Dim c As Range
For Each c In ActiveSheet.UsedRange
    arrLines = Split(c, vbLf)
     For Each Ln In arrLines
        arrWrds = Split(Ln, " ")
        For Each wrd In arrWrds
            If IsNumeric(wrd) Then
                dblWrd = CDbl(wrd)
                Rest = dblWrd - Int(dblWrd)
                If Rest <> 0 Then ' not integer
                    Number = Fix(dblWrd * 100) / 100
                    FormattedWrd = Format(Number, "#.0#")
                    If FormattedWrd <> wrd Then
                        NewWrd = "[r]" & FormattedWrd & "[r]"
                    Else
                        NewWrd = wrd
                    End If
                Else
                    NewWrd = wrd
                
                End If
            Else
                NewWrd = wrd
            End If
        NewLine = NewLine & NewWrd & " "
        Next
    NewLine = Left(NewLine, Len(NewLine) - 1)
    Result = Result & NewLine & vbLf
    NewLine = ""
    Next
    If InStr(1, Result, "[r]") Then
        FormatedString = Left(Result, Len(Result) - 1)
        Result = ""
        ArrWords = Split(FormatedString, "[r]")
        c.Value = Replace(FormatedString, "[r]", "")
        TextStart = 1
        For Idx = 0 To UBound(ArrWords)
            WrdLength = Len(ArrWords(Idx))
            If Idx Mod 2 = 0 Then
                
                With c.Characters(Start:=TextStart, Length:=WrdLength).Font
                    .Color = vbBlack
                End With
            Else ' Idx Mod 2 = 1
                With c.Characters(Start:=TextStart, Length:=WrdLength).Font
                    .Color = vbRed
                End With
            End If
            TextStart = TextStart + WrdLength
        Next
    End If
Next
End Sub

Open in new window

Regards
0
 

Author Closing Comment

by:Andreamary
ID: 39959512
Thanks Rgonzo, your second formula worked perfectly across all columns (there were 24+ columns). Thanks, Thomas, for your answer and step-by-step on how to insert the code. Because the code needed to work across 24+ columns and the red formatting was a critical component I selected Rgonzo's formula as the best solution, but appreciated your input.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

PaperPort has a feature called the "Send To Bar". It provides a convenient, drag-and-drop interface for using other installed software, such as Microsoft Office. However, this article shows that the latest Office 2016 apps (installed with an Office …
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now