[编程交流] Excel VBA:dea的7个函数

''#################################################################
''## 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