''#################################################################
''## 7 Functions to deal with feet-inches format in Excel ##
''## in form of [#'-#"] or [#'-# #/##"] or [#'-#.##"] ##
''## By Phh, 2010, last update 6/26/2022 ##
''## Functions update to work with negative feet-inches ##
''#################################################################
''## 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 ##
''## sumtoimpe() Similar to SUM function, engineering format ##
''## sumtoimpa() Similar to SUM function, architectural format ##
''## frac2num() Sub function, convert fraction to decimal ##
''#################################################################
Option Explicit
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
