Excel VBA:dea的7个函数
大家好，这是我在这里学习和发布的一系列功能，希望它们像我在日常工作中一样对你有用。
Phh公司
''#################################################################
''## Functions to deal with feet-inches format ##
''## in a form of [#'-#"] or [#'-# #/##"] or [#'-#.##"] ##
''## By Phh, 2010, last update 2021 ##
''#################################################################
''## 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, Optional argDivBy As Double) As Double
Dim startPos As Integer, ftPos As Integer, frPos As Integer
Dim rdLen, argDivNum As Double
If argDivBy > 0 Then
argDivNum = argDivBy
Else
argDivNum = 1
End If
strX = Replace(Replace(strX, """", ""), "-", "")
strX = WorksheetFunction.Trim(strX)
startPos = 1
ftPos = InStr(startPos, strX, "'")
frPos = InStr(startPos, strX, "/")
If ftPos = 0 And frPos = 0 Then
todec = (Val(strX) / argDivNum)
Exit Function
End If
If ftPos = 0 And frPos > 0 Then
todec = (frac2num(strX) / argDivNum)
Exit Function
End If
rdLen = CDbl(Left(strX, ftPos - 1)) * 12
If frPos = 0 Then
rdLen = rdLen + (Abs(Val(Mid(strX, ftPos + 1, Len(strX)))))
todec = (rdLen / argDivNum)
Exit Function
End If
rdLen = rdLen + frac2num(Mid(strX, ftPos + 1, Len(strX)))
todec = (rdLen / argDivNum)
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 toimpe(aLen As Double, Optional argRd As Variant = 16) As String
Dim rdLen As Double, argRdNum As Double
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
ElseIf argRd = 0 Then
toimpe = (Fix(aLen / 12)) & "'-" & (aLen - (12 * Fix(aLen / 12))) & """"
Exit Function
End If
rdLen = excel.WorksheetFunction.Round(aLen / argRdNum, 0) * argRdNum
toimpe = (Fix(rdLen / 12)) & "'-" & (rdLen - (12 * Fix(rdLen / 12))) & """"
End Function
Public Function toimpa(aLen As Double, Optional argRd As Variant = 16) As String
Dim rdLen As Double, argRdNum As Double
If argRd >= 1 Then
argRdNum = 1 / Fix(argRd)
ElseIf argRd < 1 And argRd > 0 Then
argRdNum = argRd
ElseIf argRd = 0 Then
toimpa = (Fix(aLen / 12)) & "'-" & excel.WorksheetFunction.Text((aLen - (12 * Fix(aLen / 12))), "0 ##/####") & """"
Exit Function
End If
rdLen = excel.WorksheetFunction.Round(aLen / argRdNum, 0) * argRdNum
toimpa = (Fix(rdLen / 12)) & "'-" & excel.WorksheetFunction.Text((rdLen - (12 * Fix(rdLen / 12))), "0 ##/####") & """"
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 of to 1/256" as default, change if required!
argRdNum = (1 / 256)
sumArray = excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
sumtoimpe = (Fix(sumArray / 12)) & "'-" & (sumArray - (12 * Fix(sumArray / 12))) & """"
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 of to 1/256" as default, change if required!
argRdNum = (1 / 256)
sumArray = excel.WorksheetFunction.Round(sumArray / argRdNum, 0) * argRdNum
sumtoimpa = (Fix(sumArray / 12)) & "'-" & excel.WorksheetFunction.Text((sumArray - (12 * Fix(sumArray / 12))), "0 ##/####") & """"
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 = Trim$(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
页:
[1]