# Microsoft Excel

# VBA - Macros

Hier einige Macros und Code Beispiele

# VBA - Makro-  Zahlen in Textumwandeln mit Komma und Rundungen

In Excel Rechtklick auf den Registerreiter des Tabellensheets und ann Code anzeigen auswählen  
[![Auswahl_792.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/7v7Vx6CDzDGR1yUg-auswahl-792.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/7v7Vx6CDzDGR1yUg-auswahl-792.png)  
Nun Rechtsklick auf Microsoft Excel Objekte -> Einfügen -> Modul

[![Auswahl_793.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/s3H0xdhk1ayA1p9D-auswahl-793.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/s3H0xdhk1ayA1p9D-auswahl-793.png)

Nun doppelklick auf das neue Modul. Nun öffnet sich ein neues Fenster.

[![Auswahl_794.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/oktyShv7RJ99rThw-auswahl-794.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/oktyShv7RJ99rThw-auswahl-794.png)

Dort diesen Inhalt einfügen. Sollten umlaute durchs kopieren nicht richtig dargestellt werden. Diese eben korrigieren.  
Und das Fenster schließen. Das fertige Modul gibts auch im Anhang, mit den korrigierten Umlauten  
hier zum Downlod [ZahlenInText.bas](https://wiki.hacker-net.de/attachments/6)

```VB.NET
Private sNWord(0 To 28) As String
Private sHWord(1 To 4) As String

Function sbInWorten(ByVal sNumber As String) As String
   sbInWorten = sbSpellNumber(sNumber, "German", "EUR")
End Function

Function sbSpellNumber(ByVal sNumber As String, _
           Optional sLang As String = "English", _
           Optional sCcy As String = "USD") As String
'Template was Microsoft's limited version:
'https://support.microsoft.com/de-de/help/213360/
'how-to-convert-a-numeric-value-into-english-words-in-excel
'This version informs the user about its limits.
'Source (EN): http://www.sulprobil.com/sbspellnumber_en/
'Source (DE): http://www.bplumhoff.de/sbinworten_de/
'(C) (P) by Bernd Plumhoff  02-Mar-2018 PB V1.0

Dim Euros As String, cents As String
Dim Result As String, Temp As String
Dim DecimalPlace As Integer, Count As Integer
Dim Place(1 To 6) As String
Dim dNumber As Double
Dim prefix As String, suffix As String

Select Case sLang
Case "English"
   Place(1) = ""
   Place(2) = " Thousand "
   Place(3) = " Million "
   Place(4) = " Billion "
   Place(5) = " Trillion "
   Place(6) = " Mantissa not wide enough for this number "
   sHWord(1) = ">>>>> Error (Absolute amount > 999999999999999)! <<<<<"
   sHWord(2) = " (rounded)"
   sHWord(3) = "Minus "
   sHWord(4) = "and"
   sNWord(0) = "zero"
   sNWord(1) = "one"
   sNWord(2) = "two"
   sNWord(3) = "three"
   sNWord(4) = "four"
   sNWord(5) = "five"
   sNWord(6) = "six"
   sNWord(7) = "seven"
   sNWord(8) = "eight"
   sNWord(9) = "nine"
   sNWord(10) = "ten"
   sNWord(11) = "eleven"
   sNWord(12) = "twelve"
   sNWord(13) = "thirteen"
   sNWord(14) = "fourteen"
   sNWord(15) = "fifteen"
   sNWord(16) = "sixteen"
   sNWord(17) = "seventeen"
   sNWord(18) = "eighteen"
   sNWord(19) = "nineteen"
   sNWord(20) = "twenty"
   sNWord(21) = "thirty"
   sNWord(22) = "fourty"
   sNWord(23) = "fifty"
   sNWord(24) = "sixty"
   sNWord(25) = "seventy"
   sNWord(26) = "eighty"
   sNWord(27) = "ninety"
   sNWord(28) = "hundred"
Case "German"
   Place(1) = ""
   Place(2) = " Tausend "
   Place(3) = " Millionen "
   Place(4) = " Milliarden "
   Place(5) = " Billionen "
   Place(6) = " Die Mantisse ist nicht groß genug für diese Zahl "
   sHWord(1) = ">>>>> Fehler (Absolutbetrag > 999999999999999)! <<<<<"
   sHWord(2) = " (gerundet)"
   sHWord(3) = "Minus "
   sHWord(4) = "und"
   sNWord(0) = "null"
   sNWord(1) = "ein"
   sNWord(2) = "zwei"
   sNWord(3) = "drei"
   sNWord(4) = "vier"
   sNWord(5) = "fünf"
   sNWord(6) = "sechs"
   sNWord(7) = "sieben"
   sNWord(8) = "acht"
   sNWord(9) = "neun"
   sNWord(10) = "zehn"
   sNWord(11) = "elf"
   sNWord(12) = "zwölf"
   sNWord(13) = "dreizehn"
   sNWord(14) = "vierzehn"
   sNWord(15) = "fünfzehn"
   sNWord(16) = "sechzehn"
   sNWord(17) = "siebzehn"
   sNWord(18) = "achtzehn"
   sNWord(19) = "neunzehn"
   sNWord(20) = "zwanzig"
   sNWord(21) = "dreißig"
   sNWord(22) = "vierzig"
   sNWord(23) = "fünfzig"
   sNWord(24) = "sechzig"
   sNWord(25) = "siebzig"
   sNWord(26) = "achtzig"
   sNWord(27) = "neunzig"
   sNWord(28) = "hundert"
End Select

'Empty string = 0
If "" = sNumber Then
   sNumber = "0"
End If
      
dNumber = sNumber + 0#
      
'If we cannot cope with it, tell the user!
If Abs(dNumber) > 999999999999999# Then
   sbSpellNumber = sHWord(1)
   Exit Function
End If

'If we have to round we present a suffix "(rounded)"
If Abs(dNumber - Round(dNumber, 2)) > 1E-16 Then
   dNumber = Round(dNumber, 2)
   suffix = sHWord(2)
End If

'Negative numbers get a prefix "Minus"
If dNumber < 0# Then
   prefix = sHWord(3)
   dNumber = -dNumber
   sNumber = Right(sNumber, Len(sNumber) - 1)
End If

sNumber = Trim(Str(sNumber))
If Left(sNumber, 1) = "." Then
   sNumber = "0" & sNumber
End If

DecimalPlace = InStr(sNumber, ".")
        
If DecimalPlace > 0 Then
   cents = GetTens(Left(Mid(sNumber, DecimalPlace + 1) & "00", 2), _
               sLang, sCcy)
   sNumber = Trim(Left(sNumber, DecimalPlace - 1))
End If

Count = 1
Do While sNumber <> ""
   Temp = GetHundreds(Right(sNumber, 3), sLang, sCcy)
   If Temp <> "" Then
       If Euros <> "" And sLang = "German" Then
           Euros = Temp & Place(Count) & " " & _
                   sHWord(4) & " " & Euros
       Else
           Euros = Temp & Place(Count) & Euros
       End If
   End If
   If Len(sNumber) > 3 Then
       sNumber = Left(sNumber, Len(sNumber) - 3)
   Else
       sNumber = ""
   End If
   Count = Count + 1
Loop
  
Select Case sCcy
Case "EUR"
   Select Case Euros
       Case ""
           Euros = sNWord(0) & " Euros"
       Case sNWord(1)
           Euros = sNWord(1) & " Euro"
       Case Else
           Euros = Euros & " Euros"
   End Select
  
   Select Case cents
       Case ""
           cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
       Case sNWord(1)
           cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
       Case Else
           cents = " " & sHWord(4) & " " & cents & " Cents"
   End Select
Case "GBP"
   Select Case Euros
       Case ""
           Euros = sNWord(0) & " Pounds"
       Case sNWord(1)
           Euros = sNWord(1) & " Pound"
       Case Else
           Euros = Euros & " Pounds"
   End Select
  
   Select Case cents
       Case ""
           cents = " " & sHWord(4) & " " & sNWord(0) & " Pence"
       Case sNWord(1)
           cents = " " & sHWord(4) & " " & sNWord(1) & " Penny"
       Case Else
           cents = " " & sHWord(4) & " " & cents & " Pence"
   End Select
Case "USD"
   Select Case Euros
       Case ""
           Euros = sNWord(0) & " Dollars"
       Case sNWord(1)
           Euros = sNWord(1) & " Dollar"
       Case Else
           Euros = Euros & " Dollars"
   End Select
  
   Select Case cents
       Case ""
           cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
       Case sNWord(1)
           cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
       Case Else
           cents = " " & sHWord(4) & " " & cents & " Cents"
   End Select
End Select

Temp = UCase(Replace(Euros & cents, "  ", " "))
Select Case sLang
Case "English"
   Temp = Application.WorksheetFunction.Proper(Temp)
   Temp = Replace(Temp, " And ", " and ")
Case "German"
   Temp = Application.WorksheetFunction.Proper(Temp)
   Temp = Replace(Temp, "Ein Millionen", "Eine Million")
   Temp = Replace(Temp, "Ein Milliarden", "Eine Milliarde")
   Temp = Replace(Temp, "Ein Billionen", "Eine Billion")
   Temp = Replace(Temp, "Dollars", "Dollar")
   Temp = Replace(Temp, "Cents", "Cent")
   Temp = Replace(Temp, "Pounds", "Pfund")
   Temp = Replace(Temp, "Pound", "Pfund")
   Temp = Replace(Temp, "Euros", "Euro")
   Temp = Replace(Temp, "Pence", "Pennies")
   Temp = Replace(Temp, " Und ", " und ")
End Select
    
sbSpellNumber = prefix & Temp & suffix

End Function

Private Function GetHundreds(ByVal sNumber, _
           Optional sLang As String = "English", _
           Optional sCcy As String = "USD") As String
Dim Result As String

If Val(sNumber) = 0 Then Exit Function
   sNumber = Right("000" & sNumber, 3)

   If Mid(sNumber, 1, 1) <> "0" Then
       Result = GetDigit(Mid(sNumber, 1, 1)) _
               & sNWord(28)
       If Mid(sNumber, 2, 2) <> "00" Then
           Result = Result & sHWord(4)
       End If
   End If

   If Mid(sNumber, 2, 1) <> "0" Then
       Result = Result & GetTens(Mid(sNumber, 2), sLang, sCcy)
   ElseIf Mid(sNumber, 3, 1) <> "0" Then
       Result = Result & GetDigit(Mid(sNumber, 3))
   End If

   GetHundreds = Result
End Function

Private Function GetTens(TensText As String, _
           Optional sLang As String = "English", _
           Optional sCcy As String = "USD")
Dim Result As String

Result = ""
If Val(Left(TensText, 1)) = 1 Then   '10-19...
   If Val(TensText) > 9 And Val(TensText) < 20 Then
       GetTens = sNWord(Val(TensText))
   End If
   Exit Function
Else                               '20-99...
   If Val(Left(TensText, 1)) > 1 And _
       Val(Left(TensText, 1)) < 10 Then
       Result = sNWord(18 + Val(Left(TensText, 1)))
   Else
       Result = GetDigit(Right(TensText, 1))
   End If
   If Right(TensText, 1) <> "0" And Left(TensText, 1) <> "0" Then
       Select Case sLang
       Case "German"
           Result = GetDigit(Right(TensText, 1)) & _
                       sHWord(4) & Result
       Case "English"
           Result = Result & GetDigit(Right(TensText, 1))
       End Select
   End If
End If
GetTens = Result
End Function

Private Function GetDigit(Digit As String) As String
If Val(Digit) < 10 Then
   GetDigit = sNWord(Val(Digit))
Else
   GetDigit = ""
End If
End Function

```

Nun den code Editor dicht machen. In eine Zeile eine Zahl schreiben und in ein anderes Feld die Formel

```
=sbInWorten(D6)

'D6 ist die Beispiel Zelle
```

[![Auswahl_796.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/OzvjuArsBuLEyCik-auswahl-796.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/OzvjuArsBuLEyCik-auswahl-796.png)

```VBScript
sSpellNumbers wäre dann in englisch

=sbSpellNumber(D6)

D6 ist die Beispielzelle
```

[![Auswahl_797.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/HBq6tGFqLu1pc49o-auswahl-797.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/HBq6tGFqLu1pc49o-auswahl-797.png)  
  
Eigene Funktion für Sprache und Währung

```
Function MeineFunktion(ByVal sNumber As String) As String
   MeineFunktion = sbSpellNumber(sNumber, "German", "GBP")
End Function


sbSpellNumber(sNumber, dann Sprache, dann Währung)




Diese Sprachen stehen zur Verfügung:

English
German


Diese Währungen stehen zur Verfügung

EUR = Euro und Cent
GBP = Pounds und Pennies
USD = Dollar und Cent
```

Beispiel von meinerFunktion Deutsch und Pfund  
  
[![Auswahl_798.png](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/scaled-1680-/zFUvAMw3vXu4amu8-auswahl-798.png)](https://wiki.hacker-net.de/uploads/images/gallery/2022-07/zFUvAMw3vXu4amu8-auswahl-798.png)  
  
  
Es können natürlich da es eine Case Abfrage ist, auch noch Währungen und Sprachen im Makro hinzugefügt werden.  
Aber in der Regel reicht uns das in Deutschland schon.

# Fehler

# Direkt nach start Excel Funktioniert nicht mehr

Beschreibung:

Ab Office 2023 und höher.  
Beim Start kommt von Excel direkt die Fehlermeldung:

[![image-1733831110937.png](https://wiki.hacker-net.de/uploads/images/gallery/2024-12/scaled-1680-/JxxYtkGMkHtrALjg-image-1733831110937.png)](https://wiki.hacker-net.de/uploads/images/gallery/2024-12/JxxYtkGMkHtrALjg-image-1733831110937.png)

Lösungen:

- Eventuell ist der Abby Transformer Schuld mit seinem Addin.  
    Dieses deinstallieren und danach wieder installieren: