Public Function BJK(ByVal Number1 As Double) As Double
'To use this in a worksheet just enter =BJK( the number you want to custom round)
'If you want to change the name you can replace BJK from Public Funtion "BJK" above
'If you change BJK above you must also change BJK in the last line of this code'
'This will only work in the workbook you paste it to.
'To place this is a workbook follow these instruuctions
'Step-1 - Click on the Developer Tab in the Menu Bar if you cannot see it _
the google how to show the Developer Tab in your version of Excel
'Step 2 - Click on the "Insert" menu then choose "Module"
'Step 3 - Copy (Crtl+c) all the code from Public Function BJK(ByVal Number1 as Double) as Double _
to "End Funtion"
'Step 4 - Paste (Crtl+v) into the Module you just created
'Step 5 - Save the Workbook
'You can also save the body of this in a txt file and if you accidently delete your workbook _
you will have the Function again
Dim X As Integer, Y As Double, Dx As String, Dy As String, IDx As Integer, IDy As Integer
Dim Dpart As String
X = CInt(Number1) 'X = whole number part :When the compuer converts Double to Integer it rounds.
If X > Number1 Then ' Check to see if Number1 was rounded up during conversion
X = X - 1
End If
Y = Number1 - X 'Y is the cents part
Y = Application.WorksheetFunction.RoundUp(Y, 2) 'When we seperate a double from an _
Interget 1.25 goes to 1.24999999 so _
This corrects the dec error
Dpart = CStr(Y) 'Y came as three charicters a decimel and two didgets
'you can only seperate string charicters not numbers _
so this converts a number to a word
Dx = Mid(Y, 3, 1) ' Seperating the number parts (0.Dx Dy)
Dy = Right(Y, 1)
IDx = CInt(Dx) ' Change the string back to a number
IDy = CInt(Dy) ' String to Number again
If Number1 < 10.01 Then 'The first condition Values less then and equal to 10
If Y < 0.25 Then 'Condition round down all under 0.25
X = X - 1
Y = 0.99
Else
If IDy < 6 Then 'Condition round down 5 and less for numbers _
larger than 0.25
IDx = IDx - 1
IDy = 9
Dx = CStr(IDx) 'Change the numbersa back to string so they can be
Dy = CStr(IDy) 'added with worring about place of didget (IDx=4, IDy=3 IDx+IDy = 7 _
'As a string IDx + IDy = 43
Dpart = "0." & Dx & Dy 'This combines the string charc into something _
That can be converted bact to decimel number
Y = CDbl(Dpart) 'Convert
Else
IDy = 9 'satisfies ythe round up 6, 7, 8
Dx = CStr(IDx)
Dy = CStr(IDy)
Dpart = "0." & Dx & Dy
Y = CDbl(Dpart)
End If
End If
Else
If Number1 < 20.01 Then 'Second Condition
If Y < 0.39 Then '.39 round down as stated in last reply "Change threshold to .39"
X = X - 1
Y = 0.99
Else
If IDy < 6 Then ' 5 Rounds Down
IDx = IDx - 1
IDy = 9
Dx = CStr(IDx)
Dy = CStr(IDy)
Dpart = "0." & Dx & Dy
Y = CDbl(Dpart)
Else
IDy = 9 '6, 7, 8 rounds up
Dx = CStr(IDx)
Dy = CStr(IDy)
Dpart = "0." & Dx & Dy
Y = CDbl(Dpart)
End If
End If
Else
If Number1 >= 20.01 Then 'Last Condition
If Y < 0.75 Then
X = X - 1
Y = 0.99
Else
If IDy < 6 Then
IDx = IDx - 1
IDy = 9
Dx = CStr(IDx)
Dy = CStr(IDy)
Dpart = "0." & Dx & Dy
Y = CDbl(Dpart)
Else
IDy = 9
Dx = CStr(IDx)
Dy = CStr(IDy)
Dpart = "0." & Dx & Dy
Y = CDbl(Dpart)
End If
End If
End If
End If
End If
MyNum = X + Y
BJK = MyNum ' Print to the Worksheet THIS IS THE OTHER BJK YOU HAVE TO CHANGE_
'IT MUST MATCH EXACTLY TO WHAT YOU REPLACED AND IS CASE SENSITIVE _
End Function
