Thema: Spendenbescheinigungen als Serienbrief drucken

StandardModule: Modul1

Sub Bescheinigung()
   Dim iRow As Integer
   iRow = 2
   With Worksheets("Adressen")
      Do Until IsEmpty(.Cells(iRow, 1))
         Range("A8:A11").ClearContents
         Range("A8").Value = .Cells(iRow, 2).Value & " " & .Cells(iRow, 1).Value
         Range("A9").Value = .Cells(iRow, 3).Value
         Range("A11").Value = .Cells(iRow, 4).Value & " " & .Cells(iRow, 5).Value
         Range("A28").Value = .Cells(iRow, 2).Value & " " & .Cells(iRow, 1).Value
         Range("A29").Value = .Cells(iRow, 3).Value
         Range("A30").Value = .Cells(iRow, 4).Value & " " & .Cells(iRow, 5).Value
         Range("A36").Value = "XXX " & .Cells(iRow, 6).Value & " DM /" & _
            ZahlWort(.Cells(iRow, 6).Value) & "/11.09.01 XXX"
         iRow = iRow + 1
         ActiveSheet.PrintPreview
      Loop
   End With
End Sub

StandardModule: Modul2

Function ZWort(dZahl As Double, Optional bln As Boolean)
   Dim dRest As Double
   dRest = WorksheetFunction.Round((dZahl - Fix(dZahl)), 2) * 100
   dZahl = Fix(dZahl)
   BisNeunzehn = Array("", "ein", "zwei", "drei", "vier", _
      "fünf", "sechs", "sieben", "acht", "neun", "zehn", _
      "elf", "zwölf", "dreizehn", "vierzehn", "fünfzehn", _
      "sechzehn", "siebzehn", "achtzehn", "neunzehn")
   Zehner = Array("", "zehn", "zwanzig", "dreißig", _
      "vierzig", "fünfzig", "sechzig", "siebzig", _
      "achtzig", "neunzig")
   Tausender = Array("", "tausend", "millionen", "milliarden")
   If dRest = 0 Then
      ZWort = Text(dZahl)
   Else
      If bln Then
         ZWort = Text(dZahl) & " " & dRest & "/00"
      Else
         ZWort = Text(dZahl)
      End If
   End If
End Function

Private Function Wort(wert As Integer) As String
   Dim h As Integer
   h = wert Mod 100
   If h < 20 Then
      Wort = BisNeunzehn(h)
   Else
      Wort = BisNeunzehn(h Mod 10) & IIf(h Mod 10 > 0, "und", "") & _
         Zehner(Int(h / 10))
   End If
   h = (wert Mod 1000 - h) / 100
   If h > 0 Then Wort = BisNeunzehn(h) & "hundert" & Wort
End Function

Private Function Text(wert As Double)
   Dim l As Integer, i As Integer, p As Integer
   If InStr(1, Str(wert), ",") = 0 And InStr(1, Str(wert), ".") = 0 Then
      For i = 1 To 1 + Int(Len(Str(wert)) / 3)
         p = Val("0" & Mid("000" + Str(wert), _
            Len("000" & Str(wert)) - i * 3 + 1, 3))
         If p > 0 Then Text = Wort(p) & Tausender(i - 1) & Text
      Next
   Else
      Text = "#Ganzzahl!"
   End If
   If Right(Text, 3) = "ein" Then Text = Text & "s"
End Function

Beiträge aus dem Excel-Forum zu den Themen Druck und Serie