Word-Serienbriefe aus Excel; Button in der Excel-Symbolleiste

Word-Serienbriefe aus Excel; Button in der Excel-Symbolleiste. Word.Application, Word.Document
Sub cmdWord_Click()
Dim WordObj As New Word.Application
Dim WordDoc As New Word.Document
Dim dName$
dName = "C:\Windows\Testdokument.doc"
On Error GoTo w
AppActivate "Microsoft Word"
Set WordObj = Word.Application
GoTo n
w:
Set WordObj = CreateObject("Word.Application")
n:
Set WordDoc = WordObj.Documents.Add(dName)
WordObj.Visible = True
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeText Text:=TextBox1.Text
WordObj.Application.Selection.TypeParagraph
If TextBox2.Text = "" Then
WordObj.Application.Selection.TypeText Text:=TextBox3.Text
Else
If TextBox1.Text <> "Firma" Then
WordObj.Application.Selection.TypeText Text:=TextBox2.Text & " " & TextBox3.Text
Else
WordObj.Application.Selection.TypeText Text:=TextBox2.Text
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeText Text:=TextBox3.Text
End If
End If
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeText Text:=TextBox4.Text & " " & TextBox5.Text
WordObj.Application.Selection.TypeParagraph
If Textbox6.Text = "D" Or Textbox6.Text = "DE" Then
WordObj.Application.Selection.TypeText Text:=TextBox7.Text & " " & TextBox8.Text
Else
WordObj.Application.Selection.TypeText Text:=Textbox6.Text & " - " & _
TextBox7.Text & " " & TextBox8.Text
End If
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeParagraph
If TextBox1.Text = "Herr" Then
WordObj.Application.Selection.TypeText Text:="Sehr geehrter Herr " & TextBox3.Text & ", "
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeParagraph
ElseIf TextBox1.Text = "Frau" Then
WordObj.Application.Selection.TypeText Text:="Sehr geehrte Frau " & TextBox3.Text & ", "
WordObj.Application.Selection.TypeParagraph
WordObj.Application.Selection.TypeParagraph
Else
WordObj.Application.Selection.TypeText Text:="Sehr geehrte "
End If
End Sub
 
... und noch eine Lösung...
Const DateiInland$ = "C:\Letter_Inland.dot"
Const DateiAusland$ = "C:\Letter_Ausland.dot"
Const BriefOrt$ = "München, den "
Dim W As Worksheet, TBereich$
'Die Word.Application muss zunächst oben im Menü referenziert werden
Dim WordObj As New Word.Application
Dim WordDoc As New Word.Document
'Variablen für Spalten
Dim Anrede$, Nachna$, Vornam$
Dim Strass$, HausNu$, Landtt$, PeElZe$, Ortttt$
'Schulungen
Dim BEword$, BEexcl$, BEaces$, BEpppt$, BEedit$
Dim i&
Sub Button1_Click()
Start_Serienbrief
End Sub
Function Start_Serienbrief()
i = 0
'Prüft ob die Word-Vorlage vorhanden ist
If VBA.Dir(DateiInland) = "" Or VBA.Dir(DateiAusland) = "" Then
VBA.MsgBox "Die Briefvorlage ist nicht vorhanden!" & VBA.Chr(10) & _
VBA.Chr(10) & "Bitte eine Vorlage erstellen und ins Verzeichnis WINNT stellen!" _
& VBA.Chr(10), VBA.vbInformation, "Info"
Exit Function
End If
Set W = ThisWorkbook.Worksheets("Schulung")
On Error GoTo CreateWordObject
VBA.AppActivate "Microsoft Word"
Set WordObj = Word.Application
GoTo next_step
CreateWordObject:
Set WordObj = CreateObject("Word.Application")
next_step:
TBereich = W.Range("A1").CurrentRegion.Rows.Count
For i = 2 To TBereich
If W.Range("F" & (i)).Text = "D" Then
Set WordDoc = WordObj.Documents.Add(DateiInland)
Else
Set WordDoc = WordObj.Documents.Add(DateiAusland)
End If
'Zeile auslesen
Anrede = W.Range("A" & (i)).Text
Nachna = W.Range("B" & (i)).Text
Vornam = W.Range("C" & (i)).Text
Strass = W.Range("D" & (i)).Text
HausNu = W.Range("E" & (i)).Text
Landtt = W.Range("F" & (i)).Text
PeElZe = W.Range("G" & (i)).Text
Ortttt = W.Range("H" & (i)).Text
'Lehrgänge lesen
BEword = W.Range("I" & (i)).Text
BEexcl = W.Range("J" & (i)).Text
BEaces = W.Range("K" & (i)).Text
BEpppt = W.Range("L" & (i)).Text
BEedit = W.Range("M" & (i)).Text
'Word Fehlermeldung abschalten
WordObj.Application.DisplayAlerts = Word.wdAlertsNone
'Seriendruck für jede Zeile starten
Call WordSerie(WordObj, Anrede, Vornam, Nachna, Strass, HausNu, _
Landtt, PeElZe, Ortttt, BEword, BEexcl, BEaces, BEpppt, BEedit)
WordDoc.Application.DisplayAlerts = Word.wdAlertsNone
'Speichern des Word-Dokuments unterbinden
WordObj.Options.SavePropertiesPrompt = False
'braucht bei mir kleine Pause, sonst Fehler
Application.Wait VBA.Now + VBA.TimeSerial(0, 0, 5)
'Speichern wird nur simuliert
WordDoc.Saved = True
Set WordDoc = Nothing
'Abfrage beim ersten Ausdruck, ob OK
If i <= 2 Then
If VBA.MsgBox("Es wird ein Testausdruck erzeugt. Ist der Testausdruck OK und " & _
VBA.vbCrLf & "soll das Drucken fortgesetzt werden? ", VBA.vbQuestion + _
VBA.vbOKCancel + VBA.vbDefaultButton2, "Testausdruck läuft...") = VBA.vbOK Then
'mach weiter
Else
WordObj.Quit
Set WordObj = Nothing
Exit Function
End If
End If
Next i
WordObj.Quit
Set WordObj = Nothing
End Function
Function WordSerie(WordObj, Anr, Vorn, Nachn, Stras, HaNr, Lant, _
PLZt, Orrt, Bword, Bexcl, Baces, Bpppt, Bedit)
On Error Resume Next
With WordObj.Application.Selection
.TypeParagraph
If Anr <> "" Then
.TypeText Text:=Anr
.TypeParagraph
End If
If Vorn = "" Then
.TypeText Text:=Nachn
Else
If Anr <> "Firma" And Anr <> "" Then
.TypeText Text:=Vorn & " " & Nachn
Else
.TypeText Text:=Nachn
.TypeParagraph
.TypeText Text:=Vorn
End If
End If
.TypeParagraph
.TypeText Text:=Stras & " " & HaNr
.TypeParagraph
If Lant = "D" Or Lant = "DE" Then
.TypeText Text:=PLZt & " " & Orrt
Else
.TypeText Text:=Lant & " - " & PLZt & " " & Orrt
End If
.TypeParagraph
.ParagraphFormat.Alignment = Word.wdAlignParagraphRight
.TypeText Text:=BriefOrt & VBA.Day(VBA.Date) & "." & VBA.Month(VBA.Date) & "." & VBA.Year(VBA.Date)
.TypeParagraph
.ParagraphFormat.Alignment = Word.wdAlignParagraphLeft
.TypeParagraph: .TypeParagraph
.TypeParagraph: .TypeParagraph
'Bereich "besuchte Kurse"
.Font.Underline = wdUnderlineSingle
.TypeText Text:="Besuchte Kurse:"
.TypeParagraph
.Font.Underline = wdUnderlineNone
If Bword <> "" And Bword <> "B" Then
.TypeText "- " & Bword & ": Microsoft Word"
.TypeParagraph
Bword = ""
End If
If Bexcl <> "" And Bexcl <> "B" Then
.TypeText "- " & Bexcl & ": Microsoft Excel"
.TypeParagraph
Bexcl = ""
End If
If Baces <> "" And Baces <> "B" Then
.TypeText "- " & Baces & ": Microsoft Access"
.TypeParagraph
Baces = ""
End If
If Bpppt <> "" And Bpppt <> "B" Then
.TypeText "- " & Bpppt & ": Microsoft Powerpoint"
.TypeParagraph
Bpppt = ""
End If
If Bedit <> "" And Bedit <> "B" Then
.TypeText "- " & Bedit & ": Microsoft Multi Editor XP"
.TypeParagraph
Bedit = ""
End If
.TypeParagraph: .TypeParagraph
'Bereich "offene Kurse"
.Font.Underline = wdUnderlineSingle
.TypeText Text:="Möchte noch besuchen:"
.TypeParagraph
.Font.Underline = wdUnderlineNone
If Bword = "B" Then
.TypeText "- Microsoft Word"
.TypeParagraph
Bword = ""
End If
If Bexcl = "B" Then
.TypeText "- Microsoft Excel"
.TypeParagraph
Bexcl = ""
End If
If Baces = "B" Then
.TypeText "- Microsoft Access"
.TypeParagraph
Baces = ""
End If
If Bpppt = "B" Then
.TypeText "- Microsoft Powerpoint"
.TypeParagraph
Bpppt = ""
End If
If Bedit = "B" Then
.TypeText "- Multi Editor XP"
.TypeParagraph
Bedit = ""
End If
'dann drucke mal
.Document.PrintOut
End With
End Function
 
... und noch eine Lösung mit Button in der Symbolleiste...
Beim Öffnen des Workbooks wird Button in Symbolleiste erzeugt
Sub Workbook_Open()
Dim myControl As CommandBarButton
On Error Resume Next
Application.WindowState = xlMaximized
Application.CommandBars("Standard").Controls("Starte Word Serienbrief").Delete
Set myControl = Application.CommandBars("Standard").Controls. _
Add(Type:=msoControlButton, Before:=5)
With myControl
.Style = msoButtonWrapCaption
.Width = 100
.State = msoButtonDown
.Caption = "Starte Word Serienbrief"
.OnAction = "Brief_Start"
.Visible = True
End With
End Sub
Formular zum Markieren der Datensätze
Sub AlleMarkieren_Click()
On Error Resume Next
Dim c&
'alle Einträge in der Listbox markieren
For c = 0 To frmSuchen.cbAuswahl.ListCount - 1
frmSuchen.cbAuswahl.Selected(c) = True
Next
End Sub
Sub cmdExit_Click()
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(TEMP1).Delete
Application.DisplayAlerts = True
Unload Me
End Sub
Sub cmdStart_Click()
Call Start_Serienbrief
End Sub
Sub UserForm_Terminate()
On Error Resume Next
frmSuchen.cmdExit_Click
WordDoc.Application.DisplayAlerts = Word.wdAlertsNone
WordObj.Options.SavePropertiesPrompt = False
WordObj.Quit
Set WordDoc = Nothing
Set WordObj = Nothing
Set W2 = Nothing
End Sub
Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> 1 Then Cancel = 1
End Sub
Modul
'Wo ist die Winword.exe installiert? Sonst geht nichts.
Public Const WinwordPfad$ = "C:\Programme\Office\Office10\"
'Ort und Name der Word-Dokumentenvorlage
Public Const Dateivorlage$ = "U:\daten\Letter.dot"
'Hier wird das fertige Word-Dokument abgespeichert
Public Const Laufwerk$ = "U:\daten\"
'Worksheet Namen nie verändern!
Public Const WNAME$ = "Mitarbeiterliste wg durchgeführ"
Public Const TEMP1$ = "Temp"
Die Word.Application muss oben im Menü (Werkzeuge - Verweise) referenziert werden.
Beim Wechsel der Office-Release neue "Microsoft Word XXX Object-Library" zuweisen!
Public WordObj As New Word.Application
Public WordDoc As New Word.Document
Public W As Worksheet
Public W2 As Worksheet
'Schulungen Überschriften
Public Const Kurs_I$ = "- Verkaufstraining Basis (Baumaschine & Stapler)"
Public Const Kurs_J$ = "- Verkaufstraining Fortgeschrittene"
Public Const Kurs_K$ = "- Verkaufstraining Refresher"
Public Const Kurs_L$ = "- Verkaufen am Telefon"
Public Const Kurs_M$ = "- Inkasso-Management"
Public Const Kurs_N$ = "- Mitarbeiterförderungsprogramm"
Public Const Kurs_O$ = "- Erfolgreiche Kundenberatung"
Public Const Kurs_P$ = "- B & F Seminare"
Public Const Kurs_Q$ = "- Kommunikationstraining für Disponenten"
Public Const Kurs_R$ = "- Ausbilderworkshop (Gewerbliche Ausbildung)"
Public Const Kurs_S$ = "- Workshop für kaufmännische Ausbildungsbeauftragte"
Public Const Kurs_T$ = "- 1 x 1 der Führungspraxis"
Public Const Kurs_U$ = "- Konflikte lösen bzw. Umgang mit schwierigen Führungssituationen" _
& VBA.vbCrLf & " (Folgeseminar zum '1x1 der Führungspraxis')"
Public Const Kurs_V$ = "- Konflikte lösen bzw. Umgang mit schwierigen Führungssituationen" _
& VBA.vbCrLf & " (ohne vorherige Teilnahme am '1x1 der Führungspraxis')"
Public Const Kurs_W$ = "- Meister / Disponenten führen Servicetechniker"
Public Const Kurs_X$ = "- Projektmanagement"
Public Const Kurs_Y$ = "- Rhetorik & Präsentation"
Public Const Kurs_Z$ = "- Verhalten und Verhandeln am Telefon"
Public Const Kurs_AA$ = "- Zielvereinbarung, Beurteilung, Förderung"
Public Const Kurs_AB$ = "- Verhalten und Verkaufen am Telefon"
Public Const Kurs_AC$ = "- MZSG"
Public Const Kurs_AD$ = "- Betriebsverfassungsrecht für Führungskräfte"
Public Const Kurs_AE$ = "- Basisschulung Baumaschinen"
Public Const Kurs_AF$ = "- Basisschulung Stapler"
Public Const Kurs_AG$ = "- Basisschulung ET/Komponenten"
Public Const Kurs_AH$ = "- Basisschulung Windows XP"
Public Const Kurs_AI$ = "- Basisschulung Kommunikation am Telefon"
Public Const Kurs_AJ$ = "- Basisschulung Telemarketing & Telefonverkauf"
Public Const Kurs_AK$ = "- Grundlagen der Erdbewegung I"
Public Const Kurs_AL$ = "- Grundlagen der Erdbewegung II"
Public Const Kurs_AM$ = "- Nachwuchsförderprogramm - NFP"
Public Const Kurs_AN$ = "- Development Center - ZDC"
'Schulungen: Variablen für "Datum auslesen"
Public Datum_I$, Datum_J$, Datum_K$, Datum_L$, Datum_M$, Datum_N$
Public Datum_O$, Datum_P$, Datum_Q$, Datum_R$, Datum_S$, Datum_T$
Public Datum_U$, Datum_V$, Datum_W$, Datum_X$, Datum_Y$, Datum_Z$
Public Datum_AA$, Datum_AB$, Datum_AC$, Datum_AD$, Datum_AE$, Datum_AF$
Public Datum_AG$, Datum_AH$, Datum_AI$, Datum_AJ$, Datum_AK$, Datum_AL$
Public Datum_AM$, Datum_AN$
Public Nachna$, Vornam$ 'Namen Kursteilnehmer
Public Pfad$, DatName$ 'Pfad & Dateiname für das Word-Dokument
Public TBereich& 'Zeilen im Worksheet
Public i&, z& 'Listbox-Zähler
Sub Brief_Start()
Dim c%
'Eventuelle "alte Word-Session" schließen
On Error Resume Next
WordObj.Options.SavePropertiesPrompt = False
WordObj.Quit
Set WordDoc = Nothing
Set WordObj = Nothing
Set W2 = Nothing
Set W = Nothing
'ist der Pfad für Winword.exe korrekt?
If VBA.Dir(WinwordPfad) = "" Then
VBA.MsgBox "Der Dateipfad für Ausführung von Winword ist nicht korrekt! " & VBA.Chr(10) & _
VBA.Chr(10) & "Bitte wenden Sie sich an Ihren Administrator!" _
& VBA.Chr(10), VBA.vbInformation, "Info"
Exit Sub
End If
'ist die Word-Vorlage vorhanden?
If VBA.Dir(Dateivorlage) = "" Then
VBA.MsgBox "Die Briefvorlage ist nicht vorhanden!" & VBA.Chr(10) & _
VBA.Chr(10) & "Bitte eine Vorlage erstellen und ins Verzeichnis " & _
Laufwerk & " stellen! " & VBA.Chr(10), VBA.vbInformation, "Info"
Exit Sub
End If
'Worksheet direkt mit Namen ansprechen
Set W = ThisWorkbook.Worksheets(WNAME)
Application.DisplayAlerts = False
'Gibt es das temporäre Worksheet schon?
For c = 1 To Worksheets.Count
If Worksheets(c).Name <> WNAME Then Worksheets(c).Delete
Next c
'Temporäres Worksheet anlegen
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = TEMP1
Set W2 = ThisWorkbook.Worksheets(TEMP1)
'Auswahl vom 1. Worksheet ins temp.Worksheet kopieren
W2.Cells.ClearContents
W.UsedRange.Copy W2.[A1]
TBereich = W2.Range("A1").CurrentRegion.Rows.Count
'Listbox laden
If TBereich > 1 Then
frmSuchen.cbAuswahl.ColumnCount = 5
frmSuchen.cbAuswahl.ColumnWidths = 65 & ";" & 55 & ";" & 80 & ";" & 35 & ";" & 55
frmSuchen.cbAuswahl.RowSource = "D2:H" & TBereich
frmSuchen.cbAuswahl.MultiSelect = fmMultiSelectExtended
'in den Worksheets die Spaltenbreite anpassen - sonst falsche Ausgabe in WORD!
W.Columns.AutoFit
W2.Columns.AutoFit
Set W = Nothing
Set W2 = Nothing
Application.DisplayAlerts = True
frmSuchen.lblHinweis.Caption = "Im linken Fenster die gewünschten Datensätze anwählen" _
& VBA.vbCrLf & VBA.vbCrLf & "(oder alles markieren)" & VBA.vbCrLf & VBA.vbCrLf & "Dann Seriendruck starten..."
'in Listbox alle Einträge markieren
frmSuchen.AlleMarkieren_Click
frmSuchen.Show
Else
'keine Teilnehmer ausgewählt = Abbruch
Set W = Nothing
Set W2 = Nothing
VBA.MsgBox "Keine Teilnehmer ausgewählt! " & VBA.Chr(10) & _
VBA.Chr(10) & "Bitte wiederholen..." & VBA.Chr(10) _
& VBA.Chr(10), VBA.vbInformation, "Info"
Application.DisplayAlerts = False
Worksheets(TEMP1).Delete
Application.DisplayAlerts = True
End If
End Sub
Function Start_Serienbrief()
i = 0: z = 0
'sind Einträge in der Listbox markiert?
For i = 0 To frmSuchen.cbAuswahl.ListCount - 1
If frmSuchen.cbAuswahl.Selected(i) = True Then
z = z + 1
End If
Next
If z = 0 Then
VBA.MsgBox "Keine Teilnehmer ausgewählt! " & VBA.Chr(10) & _
VBA.Chr(10) & "Bitte wiederholen..." & VBA.Chr(10) _
& VBA.Chr(10), VBA.vbInformation, "Info"
Exit Function
End If
i = 0: z = 0
Set W2 = ThisWorkbook.Worksheets(TEMP1)
'Word.Application aufrufen
On Error GoTo CreateWordObject
VBA.AppActivate "Microsoft Word"
Set WordObj = Word.Application
GoTo next_step
CreateWordObject:
Set WordObj = CreateObject("Word.Application")
next_step:
On Error GoTo abbruch
TBereich = W2.Range("A1").CurrentRegion.Rows.Count
Set WordDoc = WordObj.Documents.Add(Dateivorlage)
For i = 0 To frmSuchen.cbAuswahl.ListCount - 1
If frmSuchen.cbAuswahl.Selected(i) = True Then
z = z + 1
If z > 1 Then
'Seitenumbruch
WordObj.Application.Selection.InsertBreak Type:=wdPageBreak
End If
'Namen in Zeile auslesen
Nachna = W2.Range("D" & (i + 2)).Text
Vornam = W2.Range("E" & (i + 2)).Text
'Datum der Lehrgänge lesen
Datum_I = W2.Range("I" & (i + 2)).Text
Datum_J = W2.Range("J" & (i + 2)).Text
Datum_K = W2.Range("K" & (i + 2)).Text
Datum_L = W2.Range("L" & (i + 2)).Text
Datum_M = W2.Range("M" & (i + 2)).Text
Datum_N = W2.Range("N" & (i + 2)).Text
Datum_O = W2.Range("O" & (i + 2)).Text
Datum_P = W2.Range("P" & (i + 2)).Text
Datum_Q = W2.Range("Q" & (i + 2)).Text
Datum_R = W2.Range("R" & (i + 2)).Text
Datum_S = W2.Range("S" & (i + 2)).Text
Datum_T = W2.Range("T" & (i + 2)).Text
Datum_U = W2.Range("U" & (i + 2)).Text
Datum_V = W2.Range("V" & (i + 2)).Text
Datum_W = W2.Range("W" & (i + 2)).Text
Datum_X = W2.Range("X" & (i + 2)).Text
Datum_Y = W2.Range("Y" & (i + 2)).Text
Datum_Z = W2.Range("Z" & (i + 2)).Text
Datum_AA = W2.Range("AA" & (i + 2)).Text
Datum_AB = W2.Range("AB" & (i + 2)).Text
Datum_AC = W2.Range("AC" & (i + 2)).Text
Datum_AD = W2.Range("AD" & (i + 2)).Text
Datum_AE = W2.Range("AE" & (i + 2)).Text
Datum_AF = W2.Range("AF" & (i + 2)).Text
Datum_AG = W2.Range("AG" & (i + 2)).Text
Datum_AH = W2.Range("AH" & (i + 2)).Text
Datum_AI = W2.Range("AI" & (i + 2)).Text
Datum_AJ = W2.Range("AJ" & (i + 2)).Text
Datum_AK = W2.Range("AK" & (i + 2)).Text
Datum_AL = W2.Range("AL" & (i + 2)).Text
Datum_AM = W2.Range("AM" & (i + 2)).Text
Datum_AN = W2.Range("AN" & (i + 2)).Text
'Word Fehlermeldung abschalten
WordObj.Application.DisplayAlerts = Word.wdAlertsNone
'Seriendruck für jede Zeile starten
Call WordSerie(WordObj, Vornam, Nachna, _
Datum_I, Datum_J, Datum_K, Datum_L, Datum_M, Datum_N, _
Datum_O, Datum_P, Datum_Q, Datum_R, Datum_S, Datum_T, _
Datum_U, Datum_V, Datum_W, Datum_X, Datum_Y, Datum_Z, _
Datum_AA, Datum_AB, Datum_AC, Datum_AD, Datum_AE, Datum_AF, _
Datum_AG, Datum_AH, Datum_AI, Datum_AJ, Datum_AK, Datum_AL, _
Datum_AM, Datum_AN)
VBA.DoEvents
frmSuchen.lblHinweis.Caption = z & " Datensätze verarbeitet"
frmSuchen.AlleMarkieren.Enabled = False
frmSuchen.cbAuswahl.Enabled = False
frmSuchen.cmdStart.Enabled = False
frmSuchen.cmdExit.Enabled = False
WordDoc.Application.DisplayAlerts = Word.wdAlertsNone
Nachna = "": Vornam = ""
Datum_I = "": Datum_J = "": Datum_K = "": Datum_L = "": Datum_M = "": Datum_N = ""
Datum_O = "": Datum_P = "": Datum_Q = "": Datum_R = "": Datum_S = "": Datum_T = ""
Datum_U = "": Datum_V = "": Datum_W = "": Datum_X = "": Datum_Y = "": Datum_Z = ""
Datum_AA = "": Datum_AB = "": Datum_AC = "": Datum_AD = "": Datum_AE = "": Datum_AF = ""
Datum_AG = "": Datum_AH = "": Datum_AI = "": Datum_AJ = "": Datum_AK = "": Datum_AL = ""
Datum_AM = "": Datum_AN = ""
End If
Next i
'Speichern
If z >= 1 Then
DatName = Format(Now(), "yyyymmddhhmmss") & "_Trainings.doc"
Pfad = Laufwerk & DatName
WordObj.Options.SavePropertiesPrompt = False
WordDoc.SaveAs Pfad
If z = 1 Then
VBA.MsgBox z & " Datensatz wurde in Datei " & Pfad & " erzeugt.", VBA.vbInformation, "Info"
Else
VBA.MsgBox z & " Datensätze wurden in Datei " & Pfad & " erzeugt.", VBA.vbInformation, "Info"
End If
'Word öffnen
ChDrive Left(ThisWorkbook.Path, 1)
ChDir ThisWorkbook.Path
Shell WinwordPfad & "winword.exe " & Pfad, 3
Set WordDoc = Nothing
Set WordObj = Nothing
Set W2 = Nothing
Application.DisplayAlerts = False
Worksheets(TEMP1).Delete
Application.DisplayAlerts = True
Unload frmSuchen
End If
Exit Function
abbruch:
On Error Resume Next
WordObj.Options.SavePropertiesPrompt = False
WordObj.Quit
Set WordDoc = Nothing
Set WordObj = Nothing
Set W2 = Nothing
Application.DisplayAlerts = False
Worksheets(TEMP1).Delete
Application.DisplayAlerts = True
Unload frmSuchen
End Function
Function WordSerie(WordObj, Vorn, Nachn, _
Text_I$, Text_J$, Text_K$, Text_L$, Text_M$, Text_N$, _
Text_O$, Text_P$, Text_Q$, Text_R$, Text_S$, Text_T, _
Text_U$, Text_V$, Text_W$, Text_X$, Text_Y$, Text_Z$, _
Text_AA$, Text_AB$, Text_AC$, Text_AD$, Text_AE$, Text_AF$, _
Text_AG$, Text_AH$, Text_AI$, Text_AJ$, Text_AK$, Text_AL$, _
Text_AM$, Text_AN$)
Dim Training$
On Error Resume Next 'Fehler durch Word-Applikation
Training = ""
With WordObj.Application.Selection
.Font.Bold = True
.Font.Size = 12
'Nachname / Vorname schreiben
If Vorn = "" Then
.TypeText Text:=Nachn
Else
.TypeText Text:=Nachn & ", " & Vorn
End If
.TypeParagraph: .TypeParagraph
'********************************************************
'Bereich "Besuchte Kurse"
.Font.Size = 10
If (Text_I <> "" And Text_I <> "B") Or (Text_J <> "" And Text_J <> "B") Or _
(Text_K <> "" And Text_K <> "B") Or (Text_L <> "" And Text_L <> "B") Or _
(Text_M <> "" And Text_M <> "B") Or (Text_N <> "" And Text_N <> "B") Or _
(Text_O <> "" And Text_O <> "B") Or (Text_P <> "" And Text_P <> "B") Or _
(Text_Q <> "" And Text_Q <> "B") Or (Text_R <> "" And Text_R <> "B") Or _
(Text_S <> "" And Text_S <> "B") Or (Text_T <> "" And Text_T <> "B") Or _
(Text_U <> "" And Text_U <> "B") Or (Text_V <> "" And Text_V <> "B") Or _
(Text_W <> "" And Text_W <> "B") Or (Text_X <> "" And Text_X <> "B") Or _
(Text_Y <> "" And Text_Y <> "B") Or (Text_Z <> "" And Text_Z <> "B") Or _
(Text_AA <> "" And Text_AA <> "B") Or (Text_AB <> "" And Text_AB <> "B") Or _
(Text_AC <> "" And Text_AC <> "B") Or (Text_AD <> "" And Text_AD <> "B") Or _
(Text_AE <> "" And Text_AE <> "B") Or (Text_AF <> "" And Text_AF <> "B") Or _
(Text_AG <> "" And Text_AG <> "B") Or (Text_AH <> "" And Text_AH <> "B") Or _
(Text_AI <> "" And Text_AI <> "B") Or (Text_AJ <> "" And Text_AJ <> "B") Or _
(Text_AK <> "" And Text_AK <> "B") Or (Text_AL <> "" And Text_AL <> "B") Or _
(Text_AM <> "" And Text_AM <> "B") Or (Text_AN <> "" And Text_AN <> "B") Then
.TypeText Text:="Besuchte Schulungen/Trainings:"
.TypeText Text:=vbTab 'Tabulator
.TypeText Text:="Schulungsdatum:"
.Font.Bold = False
.TypeParagraph: .TypeParagraph
If Text_I <> "" And Text_I <> "B" Then
.TypeText Kurs_I & ":"
.TypeText Text:=vbTab
.TypeText Text_I
.TypeParagraph
End If
If Text_J <> "" And Text_J <> "B" Then
.TypeText Kurs_J & ":"
.TypeText Text:=vbTab
.TypeText Text_J
.TypeParagraph
End If
If Text_K <> "" And Text_K <> "B" Then
.TypeText Kurs_K & ":"
.TypeText Text:=vbTab
.TypeText Text_K
.TypeParagraph
End If
If Text_L <> "" And Text_L <> "B" Then
.TypeText Kurs_L & ":"
.TypeText Text:=vbTab
.TypeText Text_L
.TypeParagraph
End If
If Text_M <> "" And Text_M <> "B" Then
.TypeText Kurs_M & ":"
.TypeText Text:=vbTab
.TypeText Text_M
.TypeParagraph
End If
If Text_N <> "" And Text_N <> "B" Then
.TypeText Kurs_N & ":"
.TypeText Text:=vbTab
.TypeText Text_N
.TypeParagraph
End If
If Text_O <> "" And Text_O <> "B" Then
.TypeText Kurs_O & ":"
.TypeText Text:=vbTab
.TypeText Text_O
.TypeParagraph
End If
If Text_P <> "" And Text_P <> "B" Then
.TypeText Kurs_P & ":"
.TypeText Text:=vbTab
.TypeText Text_P
.TypeParagraph
End If
If Text_Q <> "" And Text_Q <> "B" Then
.TypeText Kurs_Q & ":"
.TypeText Text:=vbTab
.TypeText Text_Q
.TypeParagraph
End If
If Text_R <> "" And Text_R <> "B" Then
.TypeText Kurs_R & ":"
.TypeText Text:=vbTab
.TypeText Text_R
.TypeParagraph
End If
If Text_S <> "" And Text_S <> "B" Then
.TypeText Kurs_S & ":"
.TypeText Text:=vbTab
.TypeText Text_S
.TypeParagraph
End If
If Text_T <> "" And Text_T <> "B" Then
.TypeText Kurs_T & ":"
.TypeText Text:=vbTab
.TypeText Text_T
.TypeParagraph
End If
If Text_U <> "" And Text_U <> "B" Then
.TypeText Kurs_U & ":"
.TypeText Text:=vbTab
.TypeText Text_U
.TypeParagraph
End If
If Text_V <> "" And Text_V <> "B" Then
.TypeText Kurs_V & ":"
.TypeText Text:=vbTab
.TypeText Text_V
.TypeParagraph
End If
If Text_W <> "" And Text_W <> "B" Then
.TypeText Kurs_W & ":"
.TypeText Text:=vbTab
.TypeText Text_W
.TypeParagraph
End If
If Text_X <> "" And Text_X <> "B" Then
.TypeText Kurs_X & ":"
.TypeText Text:=vbTab
.TypeText Text_X
.TypeParagraph
End If
If Text_Y <> "" And Text_Y <> "B" Then
.TypeText Kurs_Y & ":"
.TypeText Text:=vbTab
.TypeText Text_Y
.TypeParagraph
End If
If Text_Z <> "" And Text_Z <> "B" Then
.TypeText Kurs_Z & ":"
.TypeText Text:=vbTab
.TypeText Text_Z
.TypeParagraph
End If
If Text_AA <> "" And Text_AA <> "B" Then
.TypeText Kurs_AA & ":"
.TypeText Text:=vbTab
.TypeText Text_AA
.TypeParagraph
End If
If Text_AB <> "" And Text_AB <> "B" Then
.TypeText Kurs_AB & ":"
.TypeText Text:=vbTab
.TypeText Text_AB
.TypeParagraph
End If
If Text_AC <> "" And Text_AC <> "B" Then
.TypeText Kurs_AC & ":"
.TypeText Text:=vbTab
.TypeText Text_AC
.TypeParagraph
End If
If Text_AD <> "" And Text_AD <> "B" Then
.TypeText Kurs_AD & ":"
.TypeText Text:=vbTab
.TypeText Text_AD
.TypeParagraph
End If
If Text_AE <> "" And Text_AE <> "B" Then
.TypeText Kurs_AE & ":"
.TypeText Text:=vbTab
.TypeText Text_AE
.TypeParagraph
End If
If Text_AF <> "" And Text_AF <> "B" Then
.TypeText Kurs_AF & ":"
.TypeText Text:=vbTab
.TypeText Text_AF
.TypeParagraph
End If
If Text_AG <> "" And Text_AG <> "B" Then
.TypeText Kurs_AG & ":"
.TypeText Text:=vbTab
.TypeText Text_AG
.TypeParagraph
End If
If Text_AH <> "" And Text_AH <> "B" Then
.TypeText Kurs_AH & ":"
.TypeText Text:=vbTab
.TypeText Text_AH
.TypeParagraph
End If
If Text_AI <> "" And Text_AI <> "B" Then
.TypeText Kurs_AI & ":"
.TypeText Text:=vbTab
.TypeText Text_AI
.TypeParagraph
End If
If Text_AJ <> "" And Text_AJ <> "B" Then
.TypeText Kurs_AJ & ":"
.TypeText Text:=vbTab
.TypeText Text_AJ
.TypeParagraph
End If
If Text_AK <> "" And Text_AK <> "B" Then
.TypeText Kurs_AK & ":"
.TypeText Text:=vbTab
.TypeText Text_AK
.TypeParagraph
End If
If Text_AL <> "" And Text_AL <> "B" Then
.TypeText Kurs_AL & ":"
.TypeText Text:=vbTab
.TypeText Text_AL
.TypeParagraph
End If
If Text_AM <> "" And Text_AM <> "B" Then
.TypeText Kurs_AM & ":"
.TypeText Text:=vbTab
.TypeText Text_AM
.TypeParagraph
End If
If Text_AN <> "" And Text_AN <> "B" Then
.TypeText Kurs_AN & ":"
.TypeText Text:=vbTab
.TypeText Text_AN
.TypeParagraph
End If
.TypeParagraph
Else
.Font.Bold = True
.TypeText Text:="Besuchte Schulungen/Trainings:"
.TypeParagraph: .TypeParagraph
.TypeText "- - - k e i n e - - -"
.Font.Bold = False
.TypeParagraph: .TypeParagraph
End If
'********************************************************
'Bereich "Trainingsbedarf"
If Text_I = "B" Or Text_J = "B" Or _
Text_K = "B" Or Text_L = "B" Or _
Text_M = "B" Or Text_N = "B" Or _
Text_O = "B" Or Text_P = "B" Or _
Text_Q = "B" Or Text_R = "B" Or _
Text_S = "B" Or Text_T = "B" Or _
Text_U = "B" Or Text_V = "B" Or _
Text_V = "B" Or Text_X = "B" Or _
Text_Y = "B" Or Text_Z = "B" Or _
Text_AA = "B" Or Text_AB = "B" Or _
Text_AC = "B" Or Text_AD = "B" Or _
Text_AE = "B" Or Text_AF = "B" Or _
Text_AG = "B" Or Text_AH = "B" Or _
Text_AI = "B" Or Text_AJ = "B" Or _
Text_AK = "B" Or Text_AL = "B" Or _
Text_AM = "B" Or Text_AN = "B" Then
.Font.Bold = True
.TypeText Text:="Trainingsbedarf:"
.TypeParagraph: .TypeParagraph
.Font.Bold = False
If Text_I = "B" Then
.TypeText Kurs_I
.TypeParagraph
Training = "x"
End If
If Text_J = "B" Then
.TypeText Kurs_J
.TypeParagraph
Training = "x"
End If
If Text_K = "B" Then
.TypeText Kurs_K
.TypeParagraph
Training = "x"
End If
If Text_L = "B" Then
.TypeText Kurs_L
.TypeParagraph
Training = "x"
End If
If Text_M = "B" Then
.TypeText Kurs_M
.TypeParagraph
Training = "x"
End If
If Text_N = "B" Then
.TypeText Kurs_N
.TypeParagraph
Training = "x"
End If
If Text_O = "B" Then
.TypeText Kurs_O
.TypeParagraph
Training = "x"
End If
If Text_P = "B" Then
.TypeText Kurs_P
.TypeParagraph
Training = "x"
End If
If Text_Q = "B" Then
.TypeText Kurs_Q
.TypeParagraph
Training = "x"
End If
If Text_R = "B" Then
.TypeText Kurs_R
.TypeParagraph
Training = "x"
End If
If Text_S = "B" Then
.TypeText Kurs_S
.TypeParagraph
Training = "x"
End If
If Text_T = "B" Then
.TypeText Kurs_T
.TypeParagraph
Training = "x"
End If
If Text_U = "B" Then
.TypeText Kurs_U
.TypeParagraph
Training = "x"
End If
If Text_V = "B" Then
.TypeText Kurs_V
.TypeParagraph
Training = "x"
End If
If Text_W = "B" Then
.TypeText Kurs_W
.TypeParagraph
Training = "x"
End If
If Text_X = "B" Then
.TypeText Kurs_X
.TypeParagraph
Training = "x"
End If
If Text_Y = "B" Then
.TypeText Kurs_Y
.TypeParagraph
Training = "x"
End If
If Text_Z = "B" Then
.TypeText Kurs_Z
.TypeParagraph
Training = "x"
End If
If Text_AA = "B" Then
.TypeText Kurs_AA
.TypeParagraph
Training = "x"
End If
If Text_AB = "B" Then
.TypeText Kurs_AB
.TypeParagraph
Training = "x"
End If
If Text_AC = "B" Then
.TypeText Kurs_AC
.TypeParagraph
Training = "x"
End If
If Text_AD = "B" Then
.TypeText Kurs_AD
.TypeParagraph
Training = "x"
End If
If Text_AE = "B" Then
.TypeText Kurs_AE
.TypeParagraph
Training = "x"
End If
If Text_AF = "B" Then
.TypeText Kurs_AF
.TypeParagraph
Training = "x"
End If
If Text_AG = "B" Then
.TypeText Kurs_AG
.TypeParagraph
Training = "x"
End If
If Text_AH = "B" Then
.TypeText Kurs_AH
.TypeParagraph
Training = "x"
End If
If Text_AI = "B" Then
.TypeText Kurs_AI
.TypeParagraph
Training = "x"
End If
If Text_AJ = "B" Then
.TypeText Kurs_AJ
.TypeParagraph
Training = "x"
End If
If Text_AK = "B" Then
.TypeText Kurs_AK
.TypeParagraph
Training = "x"
End If
If Text_AL = "B" Then
.TypeText Kurs_AL
.TypeParagraph
Training = "x"
End If
If Text_AM = "B" Then
.TypeText Kurs_AM
.TypeParagraph
Training = "x"
End If
If Text_AN = "B" Then
.TypeText Kurs_AN
.TypeParagraph
Training = "x"
End If
End If
'********************************************************
If (Text_I <> "" And Text_I <> "B") And (Text_J <> "" And Text_J <> "B") And _
(Text_K <> "" And Text_K <> "B") And (Text_L <> "" And Text_L <> "B") And _
(Text_M <> "" And Text_M <> "B") And (Text_N <> "" And Text_N <> "B") And _
(Text_O <> "" And Text_O <> "B") And (Text_P <> "" And Text_P <> "B") And _
(Text_Q <> "" And Text_Q <> "B") And (Text_R <> "" And Text_R <> "B") And _
(Text_S <> "" And Text_S <> "B") And (Text_T <> "" And Text_T <> "B") And _
(Text_U <> "" And Text_U <> "B") And (Text_V <> "" And Text_V <> "B") And _
(Text_W <> "" And Text_W <> "B") And (Text_X <> "" And Text_X <> "B") And _
(Text_Y <> "" And Text_Y <> "B") And (Text_Z <> "" And Text_Z <> "B") And _
(Text_AA <> "" And Text_AA <> "B") And (Text_AB <> "" And Text_AB <> "B") And _
(Text_AC <> "" And Text_AC <> "B") And (Text_AD <> "" And Text_AD <> "B") And _
(Text_AE <> "" And Text_AE <> "B") And (Text_AF <> "" And Text_AF <> "B") And _
(Text_AG <> "" And Text_AG <> "B") And (Text_AH <> "" And Text_AH <> "B") And _
(Text_AI <> "" And Text_AI <> "B") And (Text_AJ <> "" And Text_AJ <> "B") And _
(Text_AK <> "" And Text_AK <> "B") And (Text_AL <> "" And Text_AL <> "B") And _
(Text_AM <> "" And Text_AM <> "B") And (Text_AN <> "" And Text_AN <> "B") Then
.Font.Bold = True
.TypeText Text:="Trainingsbedarf:"
.TypeParagraph: .TypeParagraph
.TypeText "- - - Alle Schulungsmaßnahmen absolviert - - -"
.Font.Bold = False
ElseIf Training = "" Then
.Font.Bold = True
.TypeText Text:="Trainingsbedarf:"
.TypeParagraph: .TypeParagraph
.TypeText "- - - Keine Schulungsmaßnahmen vorgesehen - - -"
.Font.Bold = False
End If
End With
End Function
Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt