Attribute VB_Name = "Modul1"
Option Explicit
Public x_div As String
Public uw_string As String
'++++++++++++++++++++++++++++++++
'+  entwickelt von Winfried Radner
'+  e-mail: Wolf.W.Radzinski@gmx.de
'+  ohne Gewähr
'++++++++++++++++++++++++++++++++
Private Function lz_plus(ByVal x As String, ByVal y As String) As String
Dim stelle As Integer, ue As Integer
Dim lx As Long, ly As Long
Dim i As Long
lz_plus = ""
stelle = 0
ue = 0
lx = Len(x)
ly = Len(y)
Select Case lx - ly
   Case Is < 0: x = WorksheetFunction.Rept("0", ly - lx) & x
                lx = ly
   Case Is > 0: y = WorksheetFunction.Rept("0", lx - ly) & y
                ly = lx
   End Select
For i = lx To 1 Step -1
  stelle = CInt(Mid(x, i, 1)) + CInt(Mid(y, i, 1)) + ue
  ue = stelle \ 10
  stelle = stelle Mod 10
  lz_plus = CStr(stelle) & lz_plus
Next i
If ue > 0 Then lz_plus = CStr(ue) & lz_plus
Do While Left(lz_plus, 1) = "0" And Len(lz_plus) > 1
lz_plus = Right(lz_plus, Len(lz_plus) - 1)
Loop
End Function
Private Function lz_minus(ByVal x As String, ByVal y As String) As String
Dim stelle As Integer, ue As Integer
Dim lz_ms As String
Dim lx As Long, ly As Long
Dim i As Long
lz_minus = ""
lz_ms = ""
stelle = 0
ue = 0
lx = Len(x)
ly = Len(y)
Select Case lx - ly
   Case Is < 0: x = WorksheetFunction.Rept("0", ly - lx) & x
                lx = ly
   Case Is > 0: y = WorksheetFunction.Rept("0", lx - ly) & y
                ly = lx
   End Select
For i = lx To 1 Step -1
  stelle = CInt(Mid(x, i, 1)) + (Abs(9 - CInt(Mid(y, i, 1))) + ue)
  ue = stelle \ 10
  stelle = stelle Mod 10
  lz_ms = CStr(stelle) & lz_ms
Next i
i = Len(lz_ms)
If ue > 0 Then
Do While i > 0
   stelle = CInt(Mid(lz_ms, i, 1)) + ue
   ue = stelle \ 10
   stelle = stelle Mod 10
   lz_minus = CStr(stelle) & lz_minus
   i = i - 1
Loop
Do While Left(lz_minus, 1) = "0" And Len(lz_minus) > 1
  lz_minus = Right(lz_minus, Len(lz_minus) - 1)
Loop
Else
Do While i > 0
   stelle = Abs(9 - CInt(Mid(lz_ms, i, 1)))
   lz_minus = CStr(stelle) & lz_minus
   i = i - 1
Loop
Do While Left(lz_minus, 1) = "0" And Len(lz_minus) > 1
  lz_minus = Right(lz_minus, Len(lz_minus) - 1)
Loop
   If lz_minus <> "0" Then lz_minus = "-" & lz_minus
End If
End Function
Private Function kpos(ByVal x As String, Optional delim = ",") As Long
On Error Resume Next
kpos = InStr(1, x, delim)
If kpos > 0 Then kpos = Len(x) - kpos
End Function
Private Function signum(ByVal x As String) As String
signum = "+"
If Left(x, 1) = "-" Then signum = "-"
End Function
Private Function lz_p(ByVal xr As Variant, ByVal yr As Variant) As String
Dim x As String, y As String
Dim signxy As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
                  xr = CDbl(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                  y = CStr(yr)
                  yr = CDbl(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
Select Case signxy
   Case "++": lz_p = lz_plus(x, y)
   Case "+-": lz_p = lz_minus(x, y)
   Case "-+": lz_p = lz_minus(y, x)
   Case "--": lz_p = "-" & lz_plus(x, y)
   Case Else: lz_p = "error"
End Select
End Function
Private Function lz_m(ByVal xr As Variant, ByVal yr As Variant) As String
Dim x As String, y As String
Dim signxy As String
Dim lz_mtemp As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
                  xr = CDbl(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                  y = CStr(yr)
                  yr = CDbl(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
Select Case signxy
   Case "++": lz_m = lz_minus(x, y)
   Case "+-": lz_m = lz_plus(x, y)
   Case "-+": lz_mtemp = lz_plus(y, x)
                     If lz_mtemp <> "0" Then
                        lz_m = "-" & lz_mtemp
                     Else
                        lz_m = lz_mtemp
                     End If
   Case "--": lz_m = lz_minus(y, x)
   Case Else: lz_m = "error"
End Select
End Function
Public Function lz_mult(ByVal xr As Variant, ByVal yr As Variant) As String
Dim x As String, y As String
Dim signxy As String, tot_sign As String
Dim mult As String
Dim j As Long, i As Long
Dim k As Integer
Dim gz As Boolean
Dim mult2 As String, mult4 As String, mult8 As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
                  xr = CDbl(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                  y = CStr(yr)
                  yr = CDbl(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
Select Case signxy
  Case "++", "--": tot_sign = ""
  Case Else: tot_sign = "-"
End Select
mult = "0"
j = Len(y)
gz = False
If j > 0 Then
  For i = 1 To j
    k = CInt(Mid(y, i, 1))
    Select Case k
    Case Is > 0:
       Do While k > 0
         mult = lz_p(mult, x)
         k = k - 1
       Loop
       gz = True
    Case 0:
    Case Else:
    End Select
    If gz And i < j Then
       mult2 = lz_p(mult, mult)
       mult4 = lz_p(mult2, mult2)
       mult8 = lz_p(mult4, mult4)
       mult = lz_p(mult2, mult8)
     End If
  Next i
End If
lz_mult = tot_sign & mult
End Function
Public Function lz_multi(ByVal xr As Variant, ByVal yr As Variant) As String
Dim x As String, y As String, tempy As String
Dim signxy As String, tot_sign As String
Dim mult As String, mult_i As String
Dim j As Long, i As Long, jx As Long
Dim k As Integer
Dim gz As Boolean
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
                  xr = CDbl(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                  y = CStr(yr)
                  yr = CDbl(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
Select Case signxy
  Case "++", "--": tot_sign = ""
  Case Else: tot_sign = "-"
End Select
mult = "0"
j = Len(y)
jx = Len(x)
If j > jx Then
  tempy = y
  y = x
  x = tempy
  j = jx
End If
gz = False
If j > 0 Then
  For i = 1 To j
    mult_i = "0"
    k = CInt(Mid(y, i, 1))
    Select Case k
    Case Is > 0:
       mult_i = x
       If k > 1 Then mult_i = lz_p(x, x)
       Select Case k
         Case 3, 6, 7:
            mult_i = lz_p(mult_i, x)
            If k > 5 Then mult_i = lz_p(mult_i, mult_i)
            If k = 7 Then mult_i = lz_p(mult_i, x)
         Case 4, 5, 8, 9:
            mult_i = lz_p(mult_i, mult_i)
            If k = 5 Then mult_i = lz_p(mult_i, x)
            If k > 7 Then mult_i = lz_p(mult_i, mult_i)
            If k = 9 Then mult_i = lz_p(mult_i, x)
         Case Else:
       End Select
       mult = lz_p(mult, mult_i)
       gz = True
    Case 0:
    Case Else:
    End Select
    If gz And i < j Then
       mult = mult & "0"
     End If
  Next i
End If
lz_multi = tot_sign & mult
End Function
Public Function lz_div(ByVal xr As Variant, ByVal yr As Variant, Optional rest = False) As String
On Error GoTo lz_div_err
Dim x As String, y As String
Dim signxy As String, tot_sign As String
Dim divi As String
Dim j As Long, jx As Long
Dim fertig As Boolean
Dim diff As Integer
Dim rval As String
Dim yn As String, ym As String, diffn As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
                  xr = CDbl(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                  y = CStr(yr)
                  yr = CDbl(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
Select Case signxy
  Case "++", "--": tot_sign = ""
  Case Else: tot_sign = "-"
End Select
If Len(x) = 0 Then x = "0"
If Len(y) = 0 Then GoTo lz_div_err
Do While Left(x, 1) = "0"
  If Len(x) = 1 Then GoTo testy
  x = Right(x, Len(x) - 1)
  Loop
testy:
Do While Left(y, 1) = "0"
  If Len(y) <= 1 Then GoTo lz_div_err
  y = Right(y, Len(y) - 1)
  Loop
divi = "0"
j = Len(y)
jx = Len(x)
fertig = False
Do
diff = jx - j
Select Case diff
Case Is < 0: rval = x
             fertig = True
Case 0:
        If y > x Then
           If x <> "0" Then
               rval = tot_sign & x
           Else
               rval = "0"
           End If
           fertig = True
        Else
           x = lz_m(x, y)
           divi = lz_p(divi, "1")
           jx = Len(x)
           If x = "0" Then
               rval = "0"
               fertig = True
           End If
        End If
Case 1:
           x = lz_m(x, y)
           divi = lz_p(divi, "1")
           jx = Len(x)
Case Is > 1:
        yn = y & WorksheetFunction.Rept("0", diff - 1)
        diffn = "1" & WorksheetFunction.Rept("0", diff - 1)
        If x > (yn & "0") Then
           yn = yn & "0"
           diffn = diffn & "0"
           GoTo weiter
           End If
        ym = lz_mult(yn, "5")
        If x > ym Then
           yn = ym
           diffn = WorksheetFunction.Substitute(diffn, "1", "5")
           GoTo weiter
           End If
        ym = lz_mult(yn, "3")
        If x > ym Then '*3
           yn = ym
           diffn = WorksheetFunction.Substitute(diffn, "1", "3")
           End If
weiter:
        x = lz_m(x, yn)
        divi = lz_p(divi, diffn)
        jx = Len(x)
End Select
Loop Until fertig
If rest Then
   lz_div = rval
   x_div = divi
Else
   lz_div = tot_sign & divi
End If
Exit Function
lz_div_err:
   lz_div = "#WERT"
   x_div = "#WERT"
End Function
Public Function lz_DezHex(ByVal xr As Variant) As String
On Error GoTo dezhex_err
Dim x As String
Dim temp As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
   lz_DezHex = ""
   Application.Cursor = xlWait
   Do Until x = "0"
      If Len(x) > 9 Or x > "268435456" Then
         temp = lz_div(x, "268435456", True)
         x = x_div
         Else
         temp = x
         x = "0"
         End If
         If x = "0" Then
            lz_DezHex = hex$(temp) & lz_DezHex
            Else
            lz_DezHex = Right$("0000000" & hex$(temp), 7) & lz_DezHex
            End If
      Loop
   Application.Cursor = xlDefault
   Exit Function
dezhex_err:
   Application.Cursor = xlDefault
   lz_DezHex = "#WERT"
End Function
Public Function lz_DezBin(ByVal x As String) As String
On Error GoTo dezbin_err
Dim hex_temp As String
Dim fertig As Boolean
   If x = "#WERT" Then GoTo dezbin_err
   Application.Cursor = xlWait
   hex_temp = lz_DezHex(x)
   If hex_temp = "#WERT" Then GoTo dezbin_err
   hex_temp = WorksheetFunction.Substitute(hex_temp, "0", "0000")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "1", "0001")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "2", "0010")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "3", "0011")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "4", "0100")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "5", "0101")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "6", "0110")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "7", "0111")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "8", "1000")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "9", "1001")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "A", "1010")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "B", "1011")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "C", "1100")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "D", "1101")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "E", "1110")
   hex_temp = WorksheetFunction.Substitute(hex_temp, "F", "1111")
   Do
      If Left(hex_temp, 1) = "0" Then
         hex_temp = Right(hex_temp, Len(hex_temp) - 1)
         fertig = False
         Else
         fertig = True
         End If
      Loop Until fertig
   lz_DezBin = hex_temp
   Application.Cursor = xlDefault
   Exit Function
dezbin_err:
   Application.Cursor = xlDefault
   lz_DezBin = "#WERT"
End Function
Public Function lz_DezOct(ByVal xr As Variant) As String
On Error GoTo dezoct_err
Dim x As String
Dim temp As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
   lz_DezOct = ""
   Application.Cursor = xlWait
   Do Until x = "0"
      If Len(x) > 10 Or x > "1073741824" Then
         temp = lz_div(x, "1073741824", True)
         x = x_div
         Else
         temp = x
         x = "0"
         End If
         If x = "0" Then
            lz_DezOct = Oct$(temp) & lz_DezOct
            Else
            lz_DezOct = Right$("0000000000" & Oct$(temp), 10) & lz_DezOct
            End If
      Loop
   Application.Cursor = xlDefault
   Exit Function
dezoct_err:
   Application.Cursor = xlDefault
   lz_DezOct = "#WERT"
End Function
Public Function lz_BinDez(ByVal xr As Variant) As String
On Error GoTo bindez_err
Dim x As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
Application.Cursor = xlWait
lz_BinDez = "0"
Do While Len(x) > 0
   lz_BinDez = lz_plus(lz_BinDez, lz_BinDez)
   Select Case Left(x, 1)
      Case "1": lz_BinDez = lz_plus(lz_BinDez, "1")
      Case "0":
      Case Else: lz_BinDez = "#WERT"
                 Exit Function
      End Select
      x = Right(x, Len(x) - 1)
   Loop
Application.Cursor = xlDefault
Exit Function
bindez_err:
   Application.Cursor = xlDefault
   lz_BinDez = "#WERT"
End Function
Public Function lz_OctDez(ByVal xr As Variant) As String
On Error GoTo octdez_err
Dim x As String
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
Application.Cursor = xlWait
lz_OctDez = "0"
Do While Len(x) > 0
   lz_OctDez = lz_mult(lz_OctDez, "8")
   Select Case Left(x, 1)
      Case "1" To "7": lz_OctDez = lz_plus(lz_OctDez, Left(x, 1))
      Case "0":
      Case Else: lz_OctDez = "#WERT"
                 Exit Function
      End Select
      x = Right(x, Len(x) - 1)
   Loop
Application.Cursor = xlDefault
Exit Function
octdez_err:
   Application.Cursor = xlDefault
   lz_OctDez = "#WERT"
End Function
Public Function lz_HexDez(ByVal xr As Variant) As String
On Error GoTo hexdez_err
Dim x As String
Dim hex_chars As String
hex_chars = "123456789ABCDEF"
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
Application.Cursor = xlWait
lz_HexDez = "0"
Do While Len(x) > 0
   lz_HexDez = lz_mult(lz_HexDez, "16")
   Select Case Left(x, 1)
      Case "1" To "9": lz_HexDez = lz_plus(lz_HexDez, Left(x, 1))
      Case "A" To "F": lz_HexDez = lz_plus(lz_HexDez, CStr(InStr(1, hex_chars, Left(x, 1))))
      Case "0":
      Case Else: lz_HexDez = "#WERT"
                 Exit Function
      End Select
      x = Right(x, Len(x) - 1)
   Loop
Application.Cursor = xlDefault
Exit Function
hexdez_err:
   Application.Cursor = xlDefault
   lz_HexDez = "#WERT"
End Function
Public Function lz_DezBin2(ByVal x As String) As String
On Error GoTo dezbin2_err
Dim oct_temp As String
Dim fertig As Boolean
   If x = "#WERT" Then GoTo dezbin2_err
   Application.Cursor = xlWait
   oct_temp = lz_DezOct(x)
   oct_temp = WorksheetFunction.Substitute(oct_temp, "0", "000")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "1", "001")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "2", "010")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "3", "011")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "4", "100")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "5", "101")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "6", "110")
   oct_temp = WorksheetFunction.Substitute(oct_temp, "7", "111")
   Do
      If Left(oct_temp, 1) = "0" Then
         oct_temp = Right(oct_temp, Len(oct_temp) - 1)
         fertig = False
         Else
         fertig = True
         End If
      Loop Until fertig
   lz_DezBin2 = oct_temp
   Application.Cursor = xlDefault
   Exit Function
dezbin2_err:
   Application.Cursor = xlDefault
   lz_DezBin2 = "#WERT"
End Function
Public Function lz_DezIn(ByVal xr As Variant, ByVal b As Integer) As String
On Error GoTo dezin_err
Dim x As String
Dim temp As Integer
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
If b < 1 Then GoTo dezin_err
If b = 1 Then
   Do Until x = "0"
      lz_DezIn = Left(uw_string, 1) & lz_DezIn
      x = lz_m(x, "1")
      Loop
   Exit Function
   End If
If Len(uw_string) < b Then
   If b > 16 Then GoTo dezin_err
   uw_string = "0123456789ABCDEF"
   End If
   lz_DezIn = ""
   Application.Cursor = xlWait
   Do Until x = "0"
      temp = CInt(lz_div(x, CStr(b), True))
      x = x_div
      lz_DezIn = Mid$(uw_string, temp + 1, 1) & lz_DezIn
      Loop
   Application.Cursor = xlDefault
   Exit Function
dezin_err:
   Application.Cursor = xlDefault
   lz_DezIn = "#WERT"
End Function
Public Function lz_InDez(ByVal xr As Variant, ByVal b As Integer) As String
On Error GoTo indez_err
Dim x As String
Dim tempval As Integer
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                  x = CStr(xr)
   Case Else: x = xr.Text
End Select
If b < 1 Then GoTo indez_err
If Len(uw_string) < b Then
   If b > 16 Then GoTo indez_err
   uw_string = "0123456789ABCDEF"
   End If
lz_InDez = "0"
Application.Cursor = xlWait
Do While Len(x) > 0
   lz_InDez = lz_mult(lz_InDez, CStr(b))
   tempval = InStr(1, Left(uw_string, b), Left(x, 1))
   Select Case tempval
      Case Is > 0: lz_InDez = lz_plus(lz_InDez, CStr(tempval - 1))
      Case Else: lz_InDez = "#WERT"
                 Exit Function
      End Select
      x = Right(x, Len(x) - 1)
   Loop
   Application.Cursor = xlDefault
   Exit Function
indez_err:
   Application.Cursor = xlDefault
   lz_InDez = "#WERT"
End Function
Public Function lz_add(ByVal x As Variant, ByVal y As Variant) As String
   lz_add = lz_p(x, y)
End Function
Public Function lz_sub(ByVal x As Variant, ByVal y As Variant) As String
   lz_sub = lz_m(x, y)
End Function
Public Function lz_mod(ByVal x As Variant, ByVal y As Variant) As String
  lz_mod = lz_div(x, y, 1)
End Function
Function lz_abs(ByVal x) As String
If signum(x) = "-" Then
     lz_abs = WorksheetFunction.Substitute(x, "-", "", 1)
     Else
     lz_abs = x
     End If
End Function
Function lz_sum(ParamArray R() As Variant) As String
Dim a As Range
Dim c As Range
Dim i As Long
On Error GoTo lz_sum_Err
   lz_sum = 0
   For i = 0 To UBound(R())
   If VarType(R(i)) < vbArray Then
       lz_sum = lz_add(lz_sum, R(i))
       Else
       For Each a In R(i).Areas
           For Each c In a
               lz_sum = lz_add(lz_sum, c.Value)
               Next c
       Next a
       End If
    Next i
lz_sum_Err:
End Function
Function lz_fakt(ByVal xr As Variant) As String
Dim i As Long
Dim x As Long
On Error GoTo lz_fakt_Err
   lz_fakt = "1"
Select Case VarType(xr)
   Case vbString: x = CLng(xr)
   Case vbDouble: x = CLng(xr)
   Case Else: x = CLng(xr.Text)
End Select
Application.Cursor = xlWait
Select Case x
   Case 0, 1:
   Case Else:
         For i = 1 To x
             lz_fakt = lz_mult(lz_fakt, i)
             Next i
   End Select
lz_fakt_Err:
Application.Cursor = xlDefault
End Function
Function lr_div(ByVal xr As Variant, ByVal yr As Variant, Optional nk_stellen = 2, Optional nk_genauigkeit = 25) As String
On Error GoTo err_lr_div
Dim x As String, y As String
Dim tot_sign As String
Dim delim As String
Dim nkpos As Long
Dim vk As String, nk As String, rest As String
Dim i As Long
If IsNull(nk_stellen) Then nk_stellen = 2
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                                x = CStr(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                                y = CStr(yr)
   Case Else: y = yr.Text
End Select
If signum(x) <> signum(y) Then
   tot_sign = "-"
   Else
   tot_sign = ""
   End If
If signum(x) = "-" Then x = lz_abs(Right(x, Len(x) - 1))
If signum(y) = "-" Then y = lz_abs(Right(y, Len(y) - 1))
delim = ","
nkpos = kpos(y, delim) - kpos(x, delim)
'If kpos(x) > 0 Then x = WorksheetFunction.Substitute(x, delim, "")
'If kpos(Y) > 0 Then Y = WorksheetFunction.Substitute(Y, delim, "")
x = WorksheetFunction.Substitute(x, delim, "")
y = WorksheetFunction.Substitute(y, delim, "")
Application.Cursor = xlWait
   vk = lz_div(x, y)
   rest = lz_div(x, y, True)
   nk = WorksheetFunction.Rept("0", nk_genauigkeit)
If rest <> "0" Then
      For i = 1 To nk_genauigkeit + nkpos
           nk = nk & lz_div(rest & "0", y)
           rest = lz_div(rest & "0", y, True)
           Next i
      End If
'mit Abs tritt am Ende des Nachkommateils ein Fehler auf
'nk = Right(nk, nk_genauigkeit + Abs(nkpos))
If nk_genauigkeit + nkpos > 0 Then nk = Right(nk, nk_genauigkeit + nkpos)
Select Case nkpos
    Case 0:
    Case Is > 0:  vk = vk & Left(nk, nkpos)
                            nk = Right(nk, Len(nk) - nkpos)
    Case Is < 0:
                         If Len(vk) < Abs(nkpos) Then vk = WorksheetFunction.Rept("0", Len(vk) - nkpos - 1) & vk
                         nk = Right(vk, -nkpos) & nk
                         vk = Left(vk, Len(vk) + nkpos)
    Case Else:
    End Select
   i = 0
   If Len(vk) > 1 Then
   Do While Mid(vk, i + 1, 1) = "0"
        i = i + 1
        Loop
    vk = Right(vk, Len(vk) - i)
    End If
   If Len(nk) > nk_stellen Then
        nk = Left(nk, nk_stellen)
        Else
        nk = nk & WorksheetFunction.Rept("0", nk_stellen - Len(nk))
        End If
If nk_stellen > 0 Then
   lr_div = tot_sign & vk & delim & nk
   Else
   lr_div = tot_sign & vk
   End If
err_lr_div:
Application.Cursor = xlDefault
End Function
Function lr_mult(ByVal xr As Variant, ByVal yr As Variant, Optional nk_stellen = 2) As String
On Error GoTo err_lr_mult
Dim x As String, y As String
Dim tot_sign As String
Dim delim As String
Dim nkpos As Long
Dim vk As String, nk As String
Dim i As Long
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                                x = CStr(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                                y = CStr(yr)
   Case Else: y = yr.Text
End Select
If signum(x) <> signum(y) Then
   tot_sign = "-"
   Else
   tot_sign = ""
   End If
If signum(x) = "-" Then x = lz_abs(Right(x, Len(x) - 1))
If signum(y) = "-" Then y = lz_abs(Right(y, Len(y) - 1))
delim = ","
nkpos = kpos(y, delim) + kpos(x, delim)
If kpos(x) > 0 Then x = WorksheetFunction.Substitute(x, delim, "")
If kpos(y) > 0 Then y = WorksheetFunction.Substitute(y, delim, "")
Application.Cursor = xlWait
   vk = lz_multi(x, y)
   Select Case Len(vk)
   Case Is > nkpos:
          nk = Right(vk, nkpos)
          vk = Left(vk, Len(vk) - nkpos)
    Case Is = nkpos:
          nk = vk
          vk = "0"
    Case Is < nkpos:
          nk = WorksheetFunction.Rept("0", nkpos - Len(vk)) & vk
          vk = "0"
    Case Else:
    End Select
   If Len(vk) > 1 Then
      i = 0
      Do While Mid(vk, i + 1, 1) = "0"
          i = i + 1
          Loop
       vk = Right(vk, Len(vk) - i)
       End If
       If Len(nk) > nk_stellen Then
        nk = Left(nk, nk_stellen)
        Else
        nk = nk & WorksheetFunction.Rept("0", nk_stellen - Len(nk))
        End If
If nk_stellen > 0 Then
   lr_mult = tot_sign & vk & delim & nk
   Else
   lr_mult = tot_sign & vk
   End If
err_lr_mult:
Application.Cursor = xlDefault
End Function
Function lr_add(ByVal xr As Variant, ByVal yr As Variant, Optional nk_stellen = 2) As String
On Error GoTo err_lr_add
Dim x As String, y As String
Dim delim As String
Dim signxy As String
Dim nkpos As Long
Dim vk As String, nk As String
Dim i As Long
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                                x = CStr(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                                y = CStr(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
delim = ","
nkpos = WorksheetFunction.Max(kpos(y, delim), kpos(x, delim))
If kpos(x) < nkpos Then x = x & WorksheetFunction.Rept("0", nkpos - kpos(x))
If kpos(y) < nkpos Then y = y & WorksheetFunction.Rept("0", nkpos - kpos(y))
If kpos(x) > 0 Then x = WorksheetFunction.Substitute(x, delim, "")
If kpos(y) > 0 Then y = WorksheetFunction.Substitute(y, delim, "")
Application.Cursor = xlWait

Select Case signxy
   Case "++": vk = lz_p(x, y)
   Case "+-": vk = lz_m(x, y)
   Case "-+": vk = lz_m(y, x)
   Case "--": vk = "-" & lz_p(x, y)
   Case Else: vk = "error"
End Select
   
   nk = Right(vk, nkpos)
   vk = Left(vk, Len(vk) - nkpos)
   If Len(vk) > 1 Then
      i = 0
      Do While Mid(vk, i + 1, 1) = "0"
          i = i + 1
          Loop
       vk = Right(vk, Len(vk) - i)
       End If
       If Len(nk) > nk_stellen Then
        nk = Left(nk, nk_stellen)
        Else
        nk = nk & WorksheetFunction.Rept("0", nk_stellen - Len(nk))
        End If
If nk_stellen > 0 Then
   If (vk = "" Or vk = "-") Then vk = vk & "0"
   lr_add = vk & delim & nk
   Else
   lr_add = vk
   End If
err_lr_add:
Application.Cursor = xlDefault
End Function
Function lr_sub(ByVal xr As Variant, ByVal yr As Variant, Optional nk_stellen = 2) As String
On Error GoTo err_lr_sub
Dim x As String, y As String
Dim delim As String
Dim signxy As String
Dim nkpos As Long
Dim vk As String, nk As String
Dim i As Long
Select Case VarType(xr)
   Case vbString: x = xr
   Case vbDouble: xr = CDec(xr)
                                x = CStr(xr)
   Case Else: x = xr.Text
End Select
Select Case VarType(yr)
   Case vbString: y = yr
   Case vbDouble: yr = CDec(yr)
                                y = CStr(yr)
   Case Else: y = yr.Text
End Select
signxy = signum(x) & signum(y)
If signum(x) = "-" Then x = Right(x, Len(x) - 1)
If signum(y) = "-" Then y = Right(y, Len(y) - 1)
delim = ","
nkpos = WorksheetFunction.Max(kpos(y, delim), kpos(x, delim))
If kpos(x) < nkpos Then x = x & WorksheetFunction.Rept("0", nkpos - kpos(x))
If kpos(y) < nkpos Then y = y & WorksheetFunction.Rept("0", nkpos - kpos(y))
If kpos(x) > 0 Then x = WorksheetFunction.Substitute(x, delim, "")
If kpos(y) > 0 Then y = WorksheetFunction.Substitute(y, delim, "")
Application.Cursor = xlWait
   
Select Case signxy
   Case "++": vk = lz_m(x, y)
   Case "+-": vk = lz_p(x, y)
   Case "-+": vk = "-" & lz_p(x, y)
   Case "--": vk = lz_m(y, x)
   Case Else: vk = "error"
End Select
   
   nk = Right(vk, nkpos)
   vk = Left(vk, Len(vk) - nkpos)
   If Len(vk) > 1 Then
      i = 0
      Do While Mid(vk, i + 1, 1) = "0"
          i = i + 1
          Loop
       vk = Right(vk, Len(vk) - i)
       End If
       If Len(nk) > nk_stellen Then
        nk = Left(nk, nk_stellen)
        Else
        nk = nk & WorksheetFunction.Rept("0", nk_stellen - Len(nk))
        End If
If nk_stellen > 0 Then
   If (vk = "" Or vk = "-") Then vk = vk & "0"
   lr_sub = vk & delim & nk
   Else
   lr_sub = vk
   End If
err_lr_sub:
Application.Cursor = xlDefault
End Function
Function lr_abs(ByVal x) As String
If signum(x) = "-" Then
     lr_abs = WorksheetFunction.Substitute(x, "-", "", 1)
     Else
     lr_abs = x
     End If
End Function
Function lr_sum(ParamArray R() As Variant) As String
Dim a As Range
Dim c As Range
Dim i As Long
Dim nk_stellen As Integer
On Error GoTo lr_sum_Err
If IsNull(R(0)) Then
   nk_stellen = 2
   Else
   nk_stellen = R(0)
   End If
   lr_sum = 0
   For i = 1 To UBound(R())
   If VarType(R(i)) < vbArray Then
       lr_sum = lr_add(lr_sum, R(i), nk_stellen)
       Else
       For Each a In R(i).Areas
           For Each c In a
               lr_sum = lr_add(lr_sum, c.Value, nk_stellen)
               Next c
       Next a
       End If
    Next i
lr_sum_Err:
End Function
Function ttX(ByVal x As String, Optional delim = ",", Optional tt = ".", Optional ttblock = 3) As String
On Error GoTo ttX_err
Dim kpos As Long, lw As Long
Dim links As String, rechts As String, nachkomma As String
Dim i As Long
If IsNull(delim) Then delim = ","
If IsNull(tt) Then tt = "."
kpos = InStr(1, x, delim)
If kpos > 0 Then
    nachkomma = Right(x, Len(x) - kpos)
    x = Left(x, kpos - 1)
    End If
    lw = Len(x)
    ttX = ""
    i = 1
    Do While lw > ttblock
        links = Left(x, lw - ttblock)
        rechts = Right(x, ttblock)
        ttX = links & tt & rechts & Right(ttX, (ttblock + Len(tt)) * (i - 1))
        x = links
        lw = Len(x)
        i = i + 1
    Loop
    If kpos > 0 Then ttX = ttX & delim & nachkomma
ttX_err:
End Function
Function no_ttX(ByVal x As String, Optional tt = ".") As String
   no_ttX = WorksheetFunction.Substitute(x, tt, "")
End Function
Function lz_BinAND(ByVal x As Variant, ByVal y As Variant) As String
Dim i As Long
Dim temp As String
   If Len(x) < Len(y) Then
      x = WorksheetFunction.Rept("0", Len(y) - Len(x)) & x
      Else
      y = WorksheetFunction.Rept("0", Len(x) - Len(y)) & y
      End If
   lz_BinAND = "0"
   For i = 1 To Len(x)
      temp = "0"
      If Mid$(x, i, 1) = "1" And Mid$(y, i, 1) = "1" Then temp = "1"
      If lz_BinAND > "0" Then
         lz_BinAND = lz_BinAND & temp
         Else
         If temp = "1" Then lz_BinAND = temp
         End If
      Next i
End Function
Function lz_BinOR(ByVal x As Variant, ByVal y As Variant) As String
Dim i As Long
Dim temp As String
   If Len(x) < Len(y) Then
      x = WorksheetFunction.Rept("0", Len(y) - Len(x)) & x
      Else
      y = WorksheetFunction.Rept("0", Len(x) - Len(y)) & y
      End If
   lz_BinOR = "0"
   For i = 1 To Len(x)
      temp = "0"
      If Mid$(x, i, 1) = "1" Or Mid$(y, i, 1) = "1" Then temp = "1"
      If lz_BinOR > "0" Then
         lz_BinOR = lz_BinOR & temp
         Else
         If temp = "1" Then lz_BinOR = temp
         End If
      Next i
End Function
Function lz_BinXOR(ByVal x As Variant, ByVal y As Variant) As String
Dim i As Long
Dim temp As String
   If Len(x) < Len(y) Then
      x = WorksheetFunction.Rept("0", Len(y) - Len(x)) & x
      Else
      y = WorksheetFunction.Rept("0", Len(x) - Len(y)) & y
      End If
   lz_BinXOR = "0"
   For i = 1 To Len(x)
      temp = "0"
      If Mid$(x, i, 1) <> Mid$(y, i, 1) Then temp = "1"
      If lz_BinXOR > "0" Then
         lz_BinXOR = lz_BinXOR & temp
         Else
         If temp = "1" Then lz_BinXOR = temp
         End If
      Next i
End Function
Function lz_BinNOR(ByVal x As Variant, ByVal y As Variant, Optional min_bits = 16) As String
Dim i As Long
Dim temp As String
   If Len(x) < min_bits Then x = WorksheetFunction.Rept("0", min_bits - Len(x)) & x
   If Len(y) < min_bits Then y = WorksheetFunction.Rept("0", min_bits - Len(y)) & y
   If Len(x) < Len(y) Then
      x = WorksheetFunction.Rept("0", Len(y) - Len(x)) & x
      Else
      y = WorksheetFunction.Rept("0", Len(x) - Len(y)) & y
      End If
   lz_BinNOR = "0"
   For i = 1 To Len(x)
      temp = "0"
      If Mid$(x, i, 1) = "0" And Mid$(y, i, 1) = "0" Then temp = "1"
      If lz_BinNOR > "0" Then
         lz_BinNOR = lz_BinNOR & temp
         Else
         If temp = "1" Then lz_BinNOR = temp
         End If
      Next i
End Function
Function lz_BinNOT(ByVal x As Variant, Optional min_bits = 16) As String
Dim i As Long
Dim temp As String
   If Len(x) < min_bits Then x = WorksheetFunction.Rept("0", min_bits - Len(x)) & x
   lz_BinNOT = "0"
   For i = 1 To Len(x)
      temp = "0"
      If Mid$(x, i, 1) = "0" Then temp = "1"
      If lz_BinNOT > "0" Then
         lz_BinNOT = lz_BinNOT & temp
         Else
         If temp = "1" Then lz_BinNOT = temp
         End If
      Next i
End Function

Function lz_SHL(ByVal x As Variant, Optional bitanz = 16, Optional opanz = 1, Optional basis = 10) As String
On Error GoTo lz_shl_err
Dim temp As String
lz_SHL = ""
Select Case basis
   Case 2: temp = CStr(x)
   Case 10:  temp = lz_DezBin(x)
   Case Else: temp = lz_DezBin(lz_InDez(x, basis))
   End Select
If bitanz = 0 Then bitanz = Len(temp)
temp = Right(WorksheetFunction.Rept("0", bitanz) & temp & WorksheetFunction.Rept("0", opanz), bitanz)
Select Case basis
   Case 2: lz_SHL = temp
   Case 10: lz_SHL = lz_BinDez(temp)
   Case Else: lz_SHL = lz_DezIn(lz_BinDez(temp), basis)
   End Select
lz_shl_err:
End Function


Function lz_SHR(ByVal x As Variant, Optional bitanz = 16, Optional opanz = 1, Optional basis = 10) As String
On Error GoTo lz_shr_err
Dim temp As String
lz_SHR = ""
Select Case basis
   Case 2: temp = CStr(x)
   Case 10:  temp = lz_DezBin(x)
   Case Else: temp = lz_DezBin(lz_InDez(x, basis))
   End Select
If bitanz = 0 Then bitanz = Len(temp)
temp = Left(WorksheetFunction.Rept("0", opanz) & Right(WorksheetFunction.Rept("0", bitanz) & temp, bitanz), bitanz)
Select Case basis
   Case 2: lz_SHR = temp
   Case 10: lz_SHR = lz_BinDez(temp)
   Case Else: lz_SHR = lz_DezIn(lz_BinDez(temp), basis)
   End Select
lz_shr_err:
End Function


Function lz_ROR(ByVal x As Variant, Optional bitanz = 16, Optional opanz = 1, Optional basis = 10) As String
On Error GoTo lz_ror_err
Dim temp As String
lz_ROR = ""
Select Case basis
   Case 2: temp = CStr(x)
   Case 10:  temp = lz_DezBin(x)
   Case Else: temp = lz_DezBin(lz_InDez(x, basis))
   End Select
If bitanz = 0 Then bitanz = Len(temp)
temp = Left(Right(Right(WorksheetFunction.Rept("0", bitanz) & temp, bitanz), opanz) & Right(WorksheetFunction.Rept("0", bitanz) & temp, bitanz), bitanz)
Select Case basis
   Case 2: lz_ROR = temp
   Case 10: lz_ROR = lz_BinDez(temp)
   Case Else: lz_ROR = lz_DezIn(lz_BinDez(temp), basis)
   End Select
lz_ror_err:
End Function


Function lz_ROL(ByVal x As Variant, Optional bitanz = 16, Optional opanz = 1, Optional basis = 10) As String
On Error GoTo lz_rol_err
Dim temp As String
lz_ROL = ""
Select Case basis
   Case 2: temp = CStr(x)
   Case 10:  temp = lz_DezBin(x)
   Case Else: temp = lz_DezBin(lz_InDez(x, basis))
   End Select
If bitanz = 0 Then bitanz = Len(temp)
temp = Right(Right(WorksheetFunction.Rept("0", bitanz) & temp, bitanz) & Left(Right(WorksheetFunction.Rept("0", bitanz) & temp, bitanz), opanz), bitanz)
Select Case basis
   Case 2: lz_ROL = temp
   Case 10: lz_ROL = lz_BinDez(temp)
   Case Else: lz_ROL = lz_DezIn(lz_BinDez(temp), basis)
   End Select
lz_rol_err:
End Function


'-----------------------------------------------------------------------------------------------------------------15.08.2009

Public Function lr_zpow(ByVal x As String, ByVal y As String, Optional nk = 2, Optional nk_genauigkeit = 25, Optional delim = ",") As String
On Error GoTo lr_zpow_err
Dim bruch As Boolean
Dim tot_sign As String
Dim n As String, m As String

lr_zpow = ""
If kpos(y, delim) > 0 Then Exit Function
If test_Null(x & y) Then Exit Function
lr_zpow = "0"
If test_Null(x) Then Exit Function
  
If signum(y) = "+" Then
  bruch = False
  Else
  bruch = True
  End If
tot_sign = ""
If signum(x) = "-" Then
   If lz_div(y, "2", True) <> "0" Then tot_sign = "-"
   End If
y = lz_abs(y)
x = lz_abs(x)
n = "1"
lr_zpow = "1,0"
Do While y <> "0"
   If lz_div(y, "2", True) = "1" Then
      lr_zpow = lr_mult(lr_zpow, x, nk_genauigkeit)
      y = lz_sub(y, "1")
      End If
Do While lz_div(y, "2", True) <> "1"
n = lz_mult(n, "2")
y = lz_div(y, "2")
If y = "0" Then Exit Do
   x = lr_mult(x, x, nk_genauigkeit)
   Loop
Loop
If bruch Then
   lr_zpow = lr_div("1", lr_zpow, nk_genauigkeit, nk_genauigkeit + 1)
End If
lr_zpow = Left(lr_zpow & WorksheetFunction.Rept("0", nk_genauigkeit), Len(lr_zpow) - kpos(lr_zpow, delim) + nk)
If Right(lr_zpow, Len(delim)) = delim Then lr_zpow = Left(lr_zpow, Len(lr_zpow) - Len(delim))
If Left(lr_zpow, Len(delim)) = delim Then lr_zpow = "0" & lr_zpow
lr_zpow = tot_sign & lr_zpow
Exit Function
lr_zpow_err:
End Function

'Problem, wie finde ich bei einer rationalen Zahl beliebiger Länge heraus, ob sie exakt Null ist?
'Lösung? Wenn ich alle Nullen, Plus-, Minus- und Trennzeichen aus dem String entferne und der 
'resultierende String die Stringlänge Null hat, dann ist die Zahl wohl wirklich eine Null!

Public Function test_Null(ByVal x As String, Optional delim = ",") As Boolean
test_Null = False
x = WorksheetFunction.Substitute(x, delim, "")
x = WorksheetFunction.Substitute(x, "+", "")
x = WorksheetFunction.Substitute(x, "-", "")
x = WorksheetFunction.Substitute(x, "0", "")
If Len(x) = 0 Then test_Null = True
End Function