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
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
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
powershell add exchange property to a report | 12 | 52 | |
Modified Max() formula depending on values in adjacent column in Excel | 4 | 33 | |
remove dups | 10 | 37 | |
mail (32 bit) not available for a user profile in windows 10 | 8 | 17 |
Join the community of 500,000 technology professionals and ask your questions.