Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Function to convert decimal to fraction

Posted on 2012-04-04
14
Medium Priority
?
980 Views
Last Modified: 2012-04-26
Hi folks, need some urgent help in converting a macro that I have to a Function in excel. I wrote this macro ages ago and having only recently come across functions would like to have this converted into a function. I would appreciate any help that can be provided.

Macro converts a decimal into a fraction. I prefer this one over the various others I have seen as they tend to have errors and have not computed the fractions accurately enough for my liking. This one you can set your own level of accuracy required, however, you do have to go into the programming to set the selection.numberformat="0.00000" to the number of decimal places required. It would be great if you could have an input box pop up and ask for level of accuracy say up to 10 decimal places.

The coding is provided in the as below:

Sub Dec_to_Frac()
'
' Decimal to Fraction Macro
' Macro recorded 09/05/00 by Baber Beg
'
    M01 = ActiveCell.Value
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[-1]C"
    Selection.NumberFormat = "0.000000" ‘set level of accuracy
    M1F = ActiveCell.Value
    M00 = 1
   
A:
    M02 = M00 / M01
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    Selection.NumberFormat = "0.00000" ‘one decimal less than provided above
    M19 = ActiveCell.Value
    M20 = M19 - Int(M19)
    If M20 = 0 Then GoTo C
    M00 = M00 + 1
    ActiveCell.Offset(-1, 0).Range("A1").Select
    GoTo A
   
C:
    ActiveCell.Offset(2, 0).Range("A1").Select
    If M00 > M02 Then GoTo D
    ActiveCell.Value = M00
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "'/"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-3]C,R[-2]C,R[-1]C)"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 0).Range("A1").Select
        Do Until ActiveCell.Value = M01
        Selection.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Range("A1").Select
        Loop
    Selection.EntireRow.Delete
   
    End
   
D:
    M03 = M00 / M02
    M04 = Int(M03)
    ActiveCell.Value = M04
    ActiveCell.Offset(1, 0).Range("A1").Select
    M05 = M03 - M04
    ActiveCell.FormulaR1C1 = "' & "
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M05 * M02
   
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "'/"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-5]C,R[-4]C,R[-3]C,R[-2]C,R[-1]C)"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 0).Range("A1").Select
        Do Until ActiveCell.Value = M01
        Selection.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Range("A1").Select
        Loop
    Selection.EntireRow.Delete
    End
       
   
' Dec to Frac
End Sub
0
Comment
Question by:baber62
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 5
14 Comments
 
LVL 42

Expert Comment

by:dlmille
ID: 37806601
As requested, you are prompted for the # decimal places to the right of the decimal point for accuracy.

Sub Dec_to_Frac()
'
' Decimal to Fraction Macro
' Macro recorded 09/05/00 by Baber Beg
'

Dim xResult As Long

    On Error Resume Next
    xResult = InputBox("Enter Number of Decimal Places to the right of the decimal point for accuracy: ", Default:=6)
    
    If xResult = 0 Or Not IsNumeric(xResult) Then Exit Sub
    
    On Error GoTo 0
    
    M01 = ActiveCell.Value
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[-1]C"
    Selection.NumberFormat = "0." & WorksheetFunction.Rept("0", xResult) 'set level of accuracy
    M1F = ActiveCell.Value
    M00 = 1
    
A:
    M02 = M00 / M01
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    Selection.NumberFormat = "0." & WorksheetFunction.Rept("0", xResult - 1) 'one decimal less than provided above
    M19 = ActiveCell.Value
    M20 = M19 - Int(M19)
    If M20 = 0 Then GoTo C
    M00 = M00 + 1
    ActiveCell.Offset(-1, 0).Range("A1").Select
    GoTo A
    
C:
    ActiveCell.Offset(2, 0).Range("A1").Select
    If M00 > M02 Then GoTo D
    ActiveCell.Value = M00
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "'/"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-3]C,R[-2]C,R[-1]C)"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 0).Range("A1").Select
        Do Until ActiveCell.Value = M01
        Selection.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Range("A1").Select
        Loop
    Selection.EntireRow.Delete
    
    End
    
D:
    M03 = M00 / M02
    M04 = Int(M03)
    ActiveCell.Value = M04
    ActiveCell.Offset(1, 0).Range("A1").Select
    M05 = M03 - M04
    ActiveCell.FormulaR1C1 = "' & "
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M05 * M02
    
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "'/"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Value = M02
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-5]C,R[-4]C,R[-3]C,R[-2]C,R[-1]C)"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 0).Range("A1").Select
        Do Until ActiveCell.Value = M01
        Selection.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Range("A1").Select
        Loop
    Selection.EntireRow.Delete
    End
       
    
' Dec to Frac
End Sub

Open in new window


Cheers,

Dave
0
 

Author Comment

by:baber62
ID: 37806708
Thanks for your promptness Dave but I needed to convert this to a user defined function so I can add this to an add-in.
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37807040
Ok - give me a few...

Dave
0
Visualize your virtual and backup environments

Create well-organized and polished visualizations of your virtual and backup environments when planning VMware vSphere, Microsoft Hyper-V or Veeam deployments. It helps you to gain better visibility and valuable business insights.

 
LVL 42

Expert Comment

by:dlmille
ID: 37807237
I'm getting there.  By the way, why 450 points?  Just curious.
0
 

Author Comment

by:baber62
ID: 37807352
Regarding the number of points, because this is urgently required. Also in case the points have to be divided between answers.
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37807464
Ok - back to the original question.  You say you want to have this as a function, but you also say you want to have an input box pop up for level of accuracy.

Is this going to be a spreadsheet function?  Rather than an input box, perhaps a second parameter for the decimal place precision?

By the way, I'm doing a test run on your original code and its taking forever.  Give me an example number you'd be using to convert to fraction.  Is this supposed to only work with perfect fraction solutions?  It runs if I put 11.75, but runs "forever" if I use 11.751

Dave
0
 

Author Comment

by:baber62
ID: 37807553
Dave,

The code is old it's from I was learning vba. For example I have stopped the screen updating etc. also the code is longish towards the end, where it starts to delete the rows above, till the answer ends up in the cell below.

Try some of the simpler numbers for example 3.75 or 4.666 these should run quicker through the coding.

I am not too bothered about having the input box for the accuracy that was just an afterthought when I wrote the question. I normally have the first one set to five decimal places and the second selectnumber.format to four decimal places which seems satisfactory in most instances.

Baber
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37807562
Ok - do you want this as a spreadsheet function - e.g.,

[A1]=11.5
[B1]=DecToFraction(A1,6) 'where 6 is the precision?

Or do you want this as macro where you are prompted (which I provided) that is just cleaned up (which I can do)?

Dave
0
 

Author Comment

by:baber62
ID: 37807614
Spreadsheet function please.

THanks Dave.
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37808480
Ok - I think I've got it.

For quality assurance, can you provide a dozen or so numbers for comparison to the function?

Dave
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37808708
As an FYI, the code you put in for "accuracy" doesn't appear to work.  NumberFormat only changes the Display property of a range, it does not reign in relative precision.  Also, assignment to variables like M1F have no further use.

I've taken that into account on review and now am testing to see if relative accuracy can be affected more correctly.

If I'm mistaken, please correct me.  I know this is "urgent' but want to ensure you get something that works appropriately.

PS - this will run very fast, as opposed to the subroutine approach, so there will be payout on this effort!

Dave
0
 
LVL 42

Accepted Solution

by:
dlmille earned 1800 total points
ID: 37808859
Ok - when I do it in the function the same as your sub (eliminating the decimals to Excel accuracy) I get the same results as the sub.  However, when I add the formatting to less decimal places, I get a lower denominator and I believe that's correct and a more accurate result within the level of precision dictated by the function.  I changed the code to accept 0 as the number of decimal places which actually will use no precision settings to match your original subroutine results.

Without the precision constraint, the routine gets answers like 15.002 = 15 & 3/1500 as opposed to getting 15 & 1/500 which is correct with the precision constraint you designed but wasn't working in the original routine.

------------------

Another "feature" is cleaning up the precision beyond the decimal place which seems incorrect:

Example - the routine gets answers like 15.207 = 15 & 206.99999999999997/1000 for example, when it should be returning 15.207 = 15 & 207/1000

------------------
Ok - beauty is in the eyes of the beholder, and you have easy options to make the function work exactly like your sub, if you need that.  Hopefully, I've given you something that is actually more accurate & responsive to the need - and fast!

Declaration:

Dec_to_Frac(r as Range, Optional xDecPlaces as Long=0) as String

Usage:

=Dec_to_Frac(A1) 'defaults to infinite precision (within Excel limitations)
or
=Dec_to_Frac(A1,0) 'same as above
or
=Dec_to_Frac(A1,6) 'sets precision to 6 decimals past the "."

Here's the code:
Function Dec_to_Frac(r As Range, Optional xDecPlaces As Long = 0) As String
'
' Decimal to Fraction Macro
' Macro recorded 09/05/00 by Baber Beg
'
'if xDecPlaces = 0, then no precision settings are used

Dim rNumber As Range
Dim M00 As Double
Dim M01 As Double
Dim M02 As Double
Dim M04 As Double
Dim M19 As Variant
Dim M20 As Double
Dim M1F As Variant
Dim M2F As Variant
Dim M3F As Variant
Dim M4F As Variant
Dim M5F As Variant
Dim M6F As Variant
Dim M7F As Variant
Dim M8F As Variant
Dim M9F As Variant
Dim M10F As Variant

    Set rNumber = r.Cells(1, 1)
    
    M01 = rNumber.Value
    M1F = IIf(xDecPlaces = 0, M01, Format(M01, "0." & WorksheetFunction.Rept("0", xDecPlaces))) 'set level of accuracy
   
A:
    Do
        M00 = M00 + 1
        M02 = M00 / M1F 'not M01, so that precision dicated will be utilized
        If xDecPlaces > 0 Then
            M2F = Format(M02, "0." & WorksheetFunction.Rept("0", xDecPlaces - 1)) 'one decimal less than provided above
        Else
            M2F = M02
        End If
    
        M19 = M2F
        M20 = M19 - Int(M19)
        
    Loop Until M20 = 0
    
C:
    If M00 <= M02 Then
        M3F = M00 'one cell down
        M4F = "/"
        M5F = M02
        Dec_to_Frac = M3F & M4F & M5F
    Else
    
D:
        M03 = M00 / M02
        M04 = Int(M03)
        M6F = M04
        m05 = M03 - M04
        M7F = " & "
        M8F = m05 * M02
        M9F = "/"
        M10F = M02
        
'------- ELIMINATE THIS SECTION IF YOU WANT TO DISPLAY 0 NUMERATOR and/or .99999999/1000 type display
        'clean up long strings of 0's or 9's which should improve accuracy
        If Abs(M8F - Int(M8F)) < 0.0000000001 Or Abs(M8F - Int(M8F)) > 0.9999999999 Then
            If Abs(M8F - Int(M8F)) < 0.0000000001 Then
                M8F = Int(M8F)
            Else
                M8F = Int(M8F) + 1
            End If
            
            'eliminate fractional display if 0 is the numerator
            If M8F = 0 Then
                M7F = vbNullString
                M8F = vbNullString
                M9F = vbNullString
                M10F = vbNullString
            End If
        End If
'------- END OF CLEANUP SECTION WHICH CAN BE ELIMINATED IF YOU DON'T LIKE IT
        
        Dec_to_Frac = M6F & M7F & M8F & M9F & M10F
    End If
    
' Dec to Frac
End Function

Open in new window


See attached.

Cheers!

Dave
decToFraction-r1.xls
0
 

Author Closing Comment

by:baber62
ID: 37809901
WOW ...

Thanks for your effort ... the function performs superbly.
Gratefully indebted to you Dave.
0
 
LVL 42

Expert Comment

by:dlmille
ID: 37899266
Now, depending on how you're using the output, you may find this VERY interesting.  No functions required, just custom formatting.  I'm working on a solution and was researching custom formats and noticed this and thought you might find it interesting.

Note the custom format is:

# & ????/????

Check out attached worksheet - no functions, just using custom formats.

Dave
decToFraction-r2.xls
0

Featured Post

Learn Veeam advantages over legacy backup

Every day, more and more legacy backup customers switch to Veeam. Technologies designed for the client-server era cannot restore any IT service running in the hybrid cloud within seconds. Learn top Veeam advantages over legacy backup and get Veeam for the price of your renewal

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
Ever visit a website where you spotted a really cool looking Font, yet couldn't figure out which font family it belonged to, or how to get a copy of it for your own use? This article explains the process of doing exactly that, as well as showing how…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

604 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