''###################################################################
''## Added ##
''## 8 Functions to deal with FIS (feet inches sixteen) format ##
''## in form of FFIISS or IISS or SS or FF. and FF.# ##
''## By Phh, 4/3/2024 ##
''##---------------------------------------------------------------##
''## fis2dec() Convert to decimal inches (from FFIISS format) ##
''## dec2fis() Convert to FFIISS format (from decimal inches) ##
''## imp2fis() Convert imperial to FFSSII format ##
''## fis2impa() Convert FFIISS to imperial, architect format ##
''## with optional precision argument, default 1/16" ##
''## fis2impe() Convert FFIISS to imperial, engineering format ##
''## with optional precision argument, default 1/16" ##
''## sumfis2dec() Similar to SUM function, decimal format ##
''## sumfis2impa() Similar to SUM function, architectural format ##
''## sumfis2impe() Similar to SUM function, engineering format ##
''###################################################################
''## 7 Functions to deal with feet-inches format in Excel ##
''## in form of [#'-#"] or [#'-# #/##"] or [#'-#.##"] ##
''## Functions update to work with negative feet-inches ##
''## By Phh, 2010, last update 6/26/2022 ##
''##---------------------------------------------------------------##
''## todec() Convert to decimal ##
''## toimpe() Convert to imperial, engineering format ##
''## with optional precision argument, default 1/16" ##
''## toimpa() Convert to imperial, architectural format ##
''## with optional precision argument, default 1/16" ##
''## sumtodec() Similar to SUM function, decimal format ##
''## sumtoimpa() Similar to SUM function, architectural format ##
''## sumtoimpe() Similar to SUM function, engineering format ##
''## frac2num() Sub function, convert fraction to decimal ##
''###################################################################
Option Explicit
''##############################
''## Start 8 FFIISS functions ##
''##############################
Public Function fis2dec(strX As String) As Double
Dim startPos, dotPos, signofNum As Integer
strX = Trim$(strX)
If Left$(strX, 1) = "-" Then
signofNum = -1
Else
signofNum = 1
End If
strX = Replace(strX, "-", "")
startPos = 1
dotPos = InStr(startPos, strX, ".", vbTextCompare)
If dotPos > 0 Then
fis2dec = Val(strX) * 12 * signofNum
Exit Function
End If
If Len(strX) < 3 Then
fis2dec = Val(strX) / 16 * signofNum
Exit Function
End If
If Len(strX) > 4 Then
fis2dec = ((Left$(strX, Len(strX) - 4) * 12) + (Left$(Right$(strX, 4), 2)) + (Right$(strX, 2) / 16)) * signofNum
Exit Function
End If
fis2dec = (Left$(strX, Len(strX) - 2) + (Right$(strX, 2) / 16)) * signofNum
End Function
Public Function dec2fis(aNum As Double)
Dim signofNum As Integer
Dim ffNum As Double
Dim iiNum, ssNum As String
If Left$(aNum, 1) = "-" Then
signofNum = -1
Else
signofNum = 1
End If
'Abs & Round number to 1/16"
aNum = Excel.WorksheetFunction.Round(Abs(aNum) / 0.0625, 0) * 0.0625
ffNum = Fix(aNum / 12)
iiNum = Excel.WorksheetFunction.Text(Fix(aNum - (ffNum * 12)), "00")
ssNum = Excel.WorksheetFunction.Text((aNum - Fix(aNum)) * 16, "00")
dec2fis = CDbl(ffNum & iiNum & ssNum) * signofNum
End Function
Public Function imp2fis(strX As String) As Double
''Note: This imp2fis() function will use dec2fis() and todec() as sub-functions
''to convert to FFIISS format.
strX = Trim$(strX)
imp2fis = dec2fis(todec(strX))
End Function
Public Function fis2impa(strX As String, Optional argRd As Variant = 16) As String
''Note: This function will use toimpa() as sub-function
''to convert to imperial architectural format.
Dim rdLen, rawLen, argRdNum As Double
Dim startPos, dotPos, signofNum As Integer
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
End If
strX = Trim$(strX)
If Left$(strX, 1) = "-" Then
signofNum = -1
Else
signofNum = 1
End If
strX = Replace(strX, "-", "")
startPos = 1
dotPos = InStr(startPos, strX, ".", vbTextCompare)
If dotPos > 0 Then
fis2impa = toimpa(Val(strX) * 12 * signofNum, argRdNum)
Exit Function
End If
If Len(strX) < 3 Then
fis2impa = toimpa(Val(strX) / 16 * signofNum, argRdNum)
Exit Function
End If
If Len(strX) > 4 Then
fis2impa = toimpa(((Left$(strX, Len(strX) - 4) * 12) + (Left$(Right$(strX, 4), 2)) + (Right$(strX, 2) / 16)) * signofNum, argRdNum)
Exit Function
End If
fis2impa = toimpa((Left$(strX, Len(strX) - 2) + (Right$(strX, 2) / 16)) * signofNum, argRdNum)
End Function
Public Function fis2impe(strX As String, Optional argRd As Variant = 16) As String
''Note: This function will use toimpe() as sub-function
''to convert to imperial engineering format.
Dim rdLen, rawLen, argRdNum As Double
Dim startPos, dotPos, signofNum As Integer
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
End If
strX = Trim$(strX)
If Left$(strX, 1) = "-" Then
signofNum = -1
Else
signofNum = 1
End If
strX = Replace(strX, "-", "")
startPos = 1
dotPos = InStr(startPos, strX, ".", vbTextCompare)
If dotPos > 0 Then
fis2impe = toimpe(Val(strX) * 12 * signofNum, argRdNum)
Exit Function
End If
If Len(strX) < 3 Then
fis2impe = toimpe(Val(strX) / 16 * signofNum, argRdNum)
Exit Function
End If
If Len(strX) > 4 Then
fis2impe = toimpe(((Left$(strX, Len(strX) - 4) * 12) + (Left$(Right$(strX, 4), 2)) + (Right$(strX, 2) / 16)) * signofNum, argRdNum)
Exit Function
End If
fis2impe = toimpe((Left$(strX, Len(strX) - 2) + (Right$(strX, 2) / 16)) * signofNum, argRdNum)
End Function
Public Function sumfis2dec(ParamArray Xrange() As Variant) As Double
Dim sumArray As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + fis2dec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
sumfis2dec = sumArray
End Function
Public Function sumfis2impa(ParamArray Xrange() As Variant) As String
Dim sumArray As Double, argRdNum As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + fis2dec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
argRdNum = (1 / 16) 'Set round-off 1/16" for FFIISS format
sumArray = Excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
If sumArray <= -12 Or sumArray >= 12 Then
sumfis2impa = (Fix(sumArray / 12)) & "'-" & Excel.WorksheetFunction.Text(Abs(sumArray - (12 * Fix(sumArray / 12))), "0 #/####") & """"
ElseIf sumArray < 12 And sumArray > -12 Then
If (sumArray - Fix(sumArray)) = 0 Then
sumfis2impa = sumArray & """"
Else
sumfis2impa = Excel.WorksheetFunction.Text(sumArray, "# #/####") & """"
End If
End If
End Function
Public Function sumfis2impe(ParamArray Xrange() As Variant) As String
Dim sumArray As Double, argRdNum As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + fis2dec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
argRdNum = (1 / 16) 'Set round-off 1/16" for FFIISS format
sumArray = Excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
If sumArray <= -12 Or sumArray >= 12 Then
sumfis2impe = (Fix(sumArray / 12)) & "'-" & Abs(sumArray - (12 * Fix(sumArray / 12))) & """"
ElseIf sumArray < 12 And sumArray > -12 Then
sumfis2impe = sumArray & """"
End If
End Function
''############################
''## End 8 FFIISS functions ##
''############################
Public Function todec(strX As String) As Double
Dim startPos, ftPos, frPos, signofNum As Integer
Dim rdLen As Double
strX = Trim$(strX)
If Left$(strX, 1) = "-" Then
signofNum = -1
Else
signofNum = 1
End If
strX = Replace(Replace(strX, """", ""), "-", "")
startPos = 1
ftPos = InStr(startPos, strX, "'")
frPos = InStr(startPos, strX, "/")
If ftPos = 0 And frPos = 0 Then
todec = Val(strX) * signofNum
Exit Function
End If
If ftPos = 0 And frPos > 0 Then
todec = frac2num(strX) * signofNum
Exit Function
End If
rdLen = CDbl(Left$(strX, ftPos - 1)) * 12
If frPos = 0 Then
rdLen = rdLen + (Val(Mid$(strX, ftPos + 1, Len(strX))))
todec = rdLen * signofNum
Exit Function
End If
rdLen = rdLen + frac2num(Mid$(strX, ftPos + 1, Len(strX)))
todec = rdLen * signofNum
End Function
Public Function toimpe(rawLen As Double, Optional argRd As Variant = 16) As String
Dim rdLen As Double, argRdNum As Double
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
rdLen = Excel.WorksheetFunction.Round(rawLen / argRdNum, 0) * argRdNum
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
rdLen = Excel.WorksheetFunction.Round(rawLen / argRdNum, 0) * argRdNum
Else
rdLen = rawLen
End If
If Abs(Excel.WorksheetFunction.Round(rawLen / argRdNum, 0)) < Abs(argRdNum) Then
toimpe = "0"""
Exit Function
End If
If rdLen <= -12 Or rdLen >= 12 Then
toimpe = (Fix(rdLen / 12)) & "'-" & Abs(rdLen - (12 * Fix(rdLen / 12))) & """"
ElseIf rdLen < 12 And rdLen > -12 Then
toimpe = rdLen & """"
End If
End Function
Public Function toimpa(rawLen As Double, Optional argRd As Variant = 16) As String
Dim rdLen As Double, argRdNum As Double
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
rdLen = Excel.WorksheetFunction.Round(rawLen / argRdNum, 0) * argRdNum
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
rdLen = Excel.WorksheetFunction.Round(rawLen / argRdNum, 0) * argRdNum
Else
rdLen = rawLen
End If
If Abs(Excel.WorksheetFunction.Round(rawLen / argRdNum, 0)) < Abs(argRdNum) Then
toimpa = "0"""
Exit Function
End If
If rdLen <= -12 Or rdLen >= 12 Then
toimpa = (Fix(rdLen / 12)) & "'-" & Excel.WorksheetFunction.Text(Abs(rdLen - (12 * Fix(rdLen / 12))), "0 #/####") & """"
ElseIf rdLen < 12 And rdLen > -12 Then
If (rdLen - Fix(rdLen)) = 0 Then
toimpa = rdLen & """"
Else
toimpa = Excel.WorksheetFunction.Text(rdLen, "# #/####") & """"
End If
End If
End Function
Public Function sumtodec(ParamArray Xrange() As Variant) As Double
Dim sumArray As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + todec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
sumtodec = sumArray
End Function
Public Function sumtoimpe(ParamArray Xrange() As Variant) As String
Dim sumArray As Double, argRdNum As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + todec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
''########################################################################
''## Set precision round-off to 1/512" as default, change if required! ##
''########################################################################
argRdNum = (1 / 512)
sumArray = Excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
If sumArray <= -12 Or sumArray >= 12 Then
sumtoimpe = (Fix(sumArray / 12)) & "'-" & Abs(sumArray - (12 * Fix(sumArray / 12))) & """"
ElseIf sumArray < 12 And sumArray > -12 Then
sumtoimpe = sumArray & """"
End If
End Function
Public Function sumtoimpa(ParamArray Xrange() As Variant) As String
Dim sumArray As Double, argRdNum As Double
Dim theVal As Variant
Dim I As Integer
For I = LBound(Xrange) To UBound(Xrange)
If TypeOf Xrange(I) Is Range Then
For Each theVal In Xrange(I)
sumArray = sumArray + todec(CStr(theVal))
Next theVal
Else
sumArray = sumArray + CDbl(Xrange(I))
End If
Next
''########################################################################
''## Set precision round-off to 1/512" as default, change if required! ##
''########################################################################
argRdNum = (1 / 512)
sumArray = Excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
If sumArray <= -12 Or sumArray >= 12 Then
sumtoimpa = (Fix(sumArray / 12)) & "'-" & Excel.WorksheetFunction.Text(Abs(sumArray - (12 * Fix(sumArray / 12))), "0 #/####") & """"
ElseIf sumArray < 12 And sumArray > -12 Then
If (sumArray - Fix(sumArray)) = 0 Then
sumtoimpa = sumArray & """"
Else
sumtoimpa = Excel.WorksheetFunction.Text(sumArray, "# #/####") & """"
End If
End If
End Function
Function frac2num(ByVal X As String) As Double
Dim P As Integer
Dim N As Double, Num As Double, Den As Double
X = (X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Error 11
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
frac2num = N
End Function