Sub KdNrSchreiben überträgt Daten aus Excel nach Word. Dabei habe ich eine Wordvorlage, die immer wieder unter neuem Namen gespeichert wird. Nun muss ich mir aber den Namen des Dokuments merken. Der Übertrag geschieht aus Mappe 1.
Das 2. Makro funktioniert aus Mappe 2 und überträgt ebenfalls Daten. Diese sollten in das gleiche Dokument wie das 1. Makro geschrieben werden. Leider schaffe ich es nicht den Namen des Dokuments zu übertragen.
Ich dachte mir, weil ja die der Name des Dokuments ebenfalls aus der Excel-Tabelle in Mappe 1 kommt, kann ich dann im 2. Makro darauf zugreifen. Geht leiden nicht weil ich die Zuordnung der Zelle über Markierungen löse. Das 2. Makro nimmt nicht die markierte Zelle des 1. Makros.
Sub KdNrSchreiben()
Const anzBookmarks = 32
Dim BookmarkArrayUeber(anzBookmarks) As String
Dim InhaltArray(anzBookmarks) As String
Dim markedZeile As Integer
Dim markedSpalte As Integer
Dim wrdFileName As String
Dim wrdDokument
Dim master(4) As String
Dim Mitarbeiter(5) As String
Dim i As Integer
master(1) = ActiveWorkbook.Path & "\"
master(2) = ActiveWorkbook.Name
master(3) = ActiveWorkbook.Sheets(1).Name
master(4) = ActiveWorkbook.Sheets(2).Name
markedZeile = ActiveCell.Row
markedSpalte = ActiveCell.Column
Dim Dateiname As String
Dateiname = "\" + Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 2).Value + ".doc"
Dim lobjWord As Word.Application
Dim lwrdDoc As Word.Document
Set lobjWord = CreateObject("Word.Application")
Set lwrdDoc = lobjWord.Documents.Add(ActiveWorkbook.Path & "\Kundenmappe_Vorlage.dot")
With lwrdDoc
.SaveAs ActiveWorkbook.Path & Dateiname
.Close
End With
lobjWord.Quit
Set lwrdDoc = Nothing
Set lobjWord = Nothing
wrdFileName = master(1) & Dateiname
BookmarkArrayUeber(1) = "Kundennummer"
BookmarkArrayUeber(2) = "Kundenname"
BookmarkArrayUeber(3) = "VorRL"
BookmarkArrayUeber(4) = "NachRL"
BookmarkArrayUeber(5) = "RL"
BookmarkArrayUeber(6) = "TelRL"
BookmarkArrayUeber(7) = "MobilRL"
BookmarkArrayUeber(8) = "MailRL"
BookmarkArrayUeber(9) = "VorGL"
BookmarkArrayUeber(10) = "NachGL"
BookmarkArrayUeber(11) = "GL"
BookmarkArrayUeber(12) = "TelGL"
BookmarkArrayUeber(13) = "MobilGL"
BookmarkArrayUeber(14) = "MailGL"
BookmarkArrayUeber(15) = "VorACCE"
BookmarkArrayUeber(16) = "NachACCE"
BookmarkArrayUeber(17) = "ACCE"
BookmarkArrayUeber(18) = "TelACCE"
BookmarkArrayUeber(19) = "MobilACCE"
BookmarkArrayUeber(20) = "MailACCE"
BookmarkArrayUeber(21) = "VorSCM"
BookmarkArrayUeber(22) = "NachSCM"
BookmarkArrayUeber(23) = "SCM"
BookmarkArrayUeber(24) = "TelSCM"
BookmarkArrayUeber(25) = "MobilSCM"
BookmarkArrayUeber(26) = "MailSCM"
BookmarkArrayUeber(27) = "VorCRep"
BookmarkArrayUeber(28) = "NachCRep"
BookmarkArrayUeber(29) = "CRep"
BookmarkArrayUeber(30) = "TelCRep"
BookmarkArrayUeber(31) = "MobilCRep"
BookmarkArrayUeber(32) = "MailCRep"
Mitarbeiter(1) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 7).Value
Mitarbeiter(2) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 9).Value
Mitarbeiter(3) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 16).Value
Mitarbeiter(4) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 11).Value
Mitarbeiter(5) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 14).Value
InhaltArray(1) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte).Value
InhaltArray(2) = Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 2).Value
i = 1
Set wrdDokument = GetObject(wrdFileName)
Do Until Workbooks(master(2)).Sheets(master(4)).Cells(i, 1) = "" And Workbooks(master(2)).Sheets(master(4)).Cells(i + 1, 1) = ""
If Workbooks(master(2)).Sheets(master(4)).Cells(i, 1).Value = Mitarbeiter(1) Then
InhaltArray(3) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 3).Value
InhaltArray(4) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 2).Value
InhaltArray(5) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 4).Value
InhaltArray(6) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 5).Value
InhaltArray(7) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 6).Value
InhaltArray(8) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 7).Value
End If
If Workbooks(master(2)).Sheets(master(4)).Cells(i, 1).Value = Mitarbeiter(2) Then
InhaltArray(9) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 3).Value
InhaltArray(10) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 2).Value
InhaltArray(11) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 4).Value
InhaltArray(12) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 5).Value
InhaltArray(13) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 6).Value
InhaltArray(14) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 7).Value
End If
If Workbooks(master(2)).Sheets(master(4)).Cells(i, 1).Value = Mitarbeiter(3) Then
InhaltArray(15) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 3).Value
InhaltArray(16) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 2).Value
InhaltArray(17) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 4).Value
InhaltArray(18) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 5).Value
InhaltArray(19) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 6).Value
InhaltArray(20) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 7).Value
End If
If Workbooks(master(2)).Sheets(master(4)).Cells(i, 1).Value = Mitarbeiter(4) Then
InhaltArray(21) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 3).Value
InhaltArray(22) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 2).Value
InhaltArray(23) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 4).Value
InhaltArray(24) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 5).Value
InhaltArray(25) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 6).Value
InhaltArray(26) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 7).Value
End If
If Workbooks(master(2)).Sheets(master(4)).Cells(i, 1).Value = Mitarbeiter(5) Then
InhaltArray(27) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 3).Value
InhaltArray(28) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 2).Value
InhaltArray(29) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 4).Value
InhaltArray(30) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 5).Value
InhaltArray(31) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 6).Value
InhaltArray(32) = Workbooks(master(2)).Sheets(master(4)).Cells(i, 7).Value
End If
i = i + 1
Loop
For i = 1 To anzBookmarks
wrdDokument.Bookmarks(BookmarkArrayUeber(i)).Select
wrdDokument.Application.Selection.text = InhaltArray(i)
wrdDokument.Bookmarks.Add Range:=wrdDokument.Application.Selection.Range, Name:=BookmarkArrayUeber(i)
Next
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(1)).Left = 90
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(1)).Top = 620
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(1)).Copy
wrdDokument.Bookmarks("bild1").Select
wrdDokument.Application.Selection.Paste
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(2)).Left = 250
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(2)).Top = 620
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(2)).Copy
wrdDokument.Bookmarks("bild2").Select
wrdDokument.Application.Selection.Paste
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(3)).Left = 410
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(3)).Top = 620
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(3)).Copy
wrdDokument.Bookmarks("bild3").Select
wrdDokument.Application.Selection.Paste
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(4)).Left = 115
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(4)).Top = 180
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(4)).Copy
wrdDokument.Bookmarks("bild4").Select
wrdDokument.Application.Selection.Paste
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(5)).Left = 340
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(5)).Top = 180
ActiveWorkbook.Sheets(3).Shapes(Mitarbeiter(5)).Copy
wrdDokument.Bookmarks("bild5").Select
wrdDokument.Application.Selection.Paste
wrdDokument.Close
Set wrdDokument = Nothing
End Sub
Sub CopyRL() ' Kopiert den markierten Mitarbeiter an die Stelle des RL im Word-Dokument "Kundenmappe.doc"
Const anzBookmarks = 6
Dim BookmarkArrayRL(anzBookmarks) As String
Dim InhaltArray(anzBookmarks) As String
Dim markedSpalte As Integer
Dim markedZeile As Integer
Dim wrdFileName As String
Dim wrdDokument
Dim master(4) As String
master(1) = ActiveWorkbook.Path & "\"
master(2) = ActiveWorkbook.Name
master(3) = ActiveWorkbook.Sheets(1).Name
master(4) = ActiveWorkbook.Sheets(2).Name
Dateiname = "\" + Workbooks(master(2)).Sheets(master(3)).Cells(markedZeile, markedSpalte + 2).Value + ".doc"
BookmarkArrayRL(1) = "VorRL"
BookmarkArrayRL(2) = "NachRL"
BookmarkArrayRL(3) = "RL"
BookmarkArrayRL(4) = "TelRL"
BookmarkArrayRL(5) = "MobilRL"
BookmarkArrayRL(6) = "MailRL"
markedZeile = ActiveCell.Row
markedSpalte = ActiveCell.Column
InhaltArray(2) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte).Value
InhaltArray(1) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte + 1).Value
InhaltArray(3) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte + 2).Value
InhaltArray(4) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte + 3).Value
InhaltArray(5) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte + 4).Value
InhaltArray(6) = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte + 5).Value
Set wrdDokument = GetObject(wrdFileName)
For i = 1 To anzBookmarks
wrdDokument.Bookmarks(BookmarkArrayRL(i)).Select
wrdDokument.Application.Selection.text = InhaltArray(i)
wrdDokument.Bookmarks.Add Range:=wrdDokument.Application.Selection.Range, Name:=BookmarkArrayRL(i)
Next
Dim PersNr As Integer
PersNr = Workbooks(master(2)).Sheets(master(4)).Cells(markedZeile, markedSpalte - 1).Value
ActiveWorkbook.Sheets(3).Shapes(PersNr).Left = 90
ActiveWorkbook.Sheets(3).Shapes(PersNr).Top = 620
ActiveWorkbook.Sheets(3).Shapes(PersNr).Copy
wrdDokument.Bookmarks("bild1").Select
wrdDokument.Application.Selection.Paste
wrdDokument.Close
Set wrdDokument = Nothing
End Sub