Sub übertragen()
Dim daten
Dim wApp As Object
Dim pfad As String
Dim doc As Object
Dim kap21da As Boolean
Dim kap21range As Long
Dim kap21folrange As Long
Dim kap As Object
Dim i As Long
Dim wzellen As Long
Dim tab1 As Long
Dim tabda As Boolean
Dim anztab As Long
Dim tabellen()
Dim verantwortliche()
Dim ende As Long
Dim zeile As Long
Dim user As Long
Dim speicherda As Boolean
Dim akttabelle As Long
Dim tabspeicher()
Dim titelzeile As Long
ReDim tabellen(1 To 15, 0)
ReDim verantwortlich(10)
ReDim tabspeicher(0)
ende = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
For zeile = 7 To ende
If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 0 Then titelzeile = zeile
If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 1 And Left(ActiveSheet.Cells(zeile, 3), 1) <> "M" Then
ReDim Preserve tabellen(1 To 15, UBound(tabellen, 2) + 1)
tabellen(1, UBound(tabellen, 2)) = ""
tabellen(2, UBound(tabellen, 2)) = "AP " & ActiveSheet.Cells(titelzeile, 3)
tabellen(3, UBound(tabellen, 2)) = ActiveSheet.Cells(titelzeile, 4)
tabellen(4, UBound(tabellen, 2)) = "AP " & ActiveSheet.Cells(zeile, 3)
tabellen(5, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 4)
tabellen(6, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 54)
tabellen(7, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 53)
For user = 1 To 10
If InStr(1, tabellen(7, UBound(tabellen, 2)), Chr(64 + user), vbTextCompare) > 0 Or InStr(1, tabellen(7, UBound(tabellen, 2)), Chr(96 + user), vbTextCompare) > 1 Then verantwortlich(user) = verantwortlich(user) & UBound(tabellen, 2) & ","
Next user
tabellen(8, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 52)
End If
If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 1 And Left(ActiveSheet.Cells(zeile, 3), 1) = "M" Then
tabellen(9, UBound(tabellen, 2)) = tabellen(9, UBound(tabellen, 2)) & ActiveSheet.Cells(zeile, 3) & " " & ActiveSheet.Cells(zeile, 4) & Chr(10)
End If
If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 2 Then
tabellen(10, UBound(tabellen, 2)) = tabellen(10, UBound(tabellen, 2)) & ActiveSheet.Cells(zeile, 3) & " " & ActiveSheet.Cells(zeile, 4) & Chr(10)
End If
Next zeile
ReDim Preserve tabspeicher(UBound(tabellen, 2) + 2)
Set wApp = CreateObject("Word.Application")
speicherda = False
For user = 1 To 1
pfad = "C:\Users\ich\Desktop\umgebung\vorlage.doc"
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
wApp.Documents.Open pfad
Set doc = wApp.ActiveDocument
kap21da = False
kap21range = 0
kap21folrange = doc.Range.End
For Each kap In doc.Paragraphs
If kap.OutlineLevel < 10 And kap.Range.Text <> Chr(13) Then
If kap21da = True Then
kap21folrange = kap.Range.Start
Exit For
End If
If Left(kap.Range.Text, 3) = "2.1" Then
kap21range = kap.Range.Start
kap21da = True
End If
End If
Next kap
If kap21da = False Then
MsgBox "Das Kapitel 2.1. wurde nicht gefunden. Das Programm wird beendet.", , "Kapitelfehler"
wApp.Documents(pfad).Close SaveChanges:=True
wApp.Quit
Close
End If
tabda = False
If doc.Tables.Count > 0 Then
For anztab = 1 To doc.Tables.Count
If doc.Tables(anztab).Range.Start > kap21range And doc.Tables(anztab).Range.Start < kap21folrange Then
tabda = True
tab1 = anztab
Exit For
End If
Next anztab
End If
If speicherda = False Then
Set neu = wApp.Documents.Add
speicherda = True
End If
If tabda = False Then
Else
tabspeicher(0) = 1
tabspeicher(1) = 1
doc.Tables(tab1).Range.copy
neu.Activate
wApp.Selection.Paste
wApp.Selection.EndKey Unit:=wdStory
wApp.Selection.TypeParagraph
neu.Tables(1).Rows.Alignment = wdAlignRowCenter
neu.Tables(1).Rows.WrapAroundText = False
doc.Activate
End If
For akttabelle = 1 To UBound(Split(verantwortlich(user), ","))
temp = Split(verantwortlich(user), ",")(akttabelle - 1)
If IsNumeric(temp) = True And temp <> "" Then
If tabellen(1, temp) = "" And akttabelle > 1 Then
neu.Activate
neu.Tables(1).Range.copy
doc.Activate
wApp.Selection.Paste
tab1 = doc.Tables.Count
doc.Range(doc.Tables(tab1).Range.End, doc.Tables(tab1).Range.End).Select
wApp.Selection.TypeParagraph
End If
wApp.ActiveDocument.Tables(tab1).Cell(1, 1) = wApp.ActiveDocument.Tables(tab1).Cell(1, 1) & Chr(10) & tabellen(2, akttabelle) & " " & tabellen(3, akttabelle) & Chr(10) & tabellen(4, akttabelle) & " " & tabellen(5, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(1, 2) = wApp.ActiveDocument.Tables(tab1).Cell(1, 2) & Chr(10) & tabellen(6, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(4, 2) = tabellen(7, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(5, 2) = tabellen(8, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(6, 2) = tabellen(9, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(7, 2) = tabellen(4, akttabelle)
wApp.ActiveDocument.Tables(tab1).Cell(8, 2) = tabellen(10, akttabelle)
If tabellen(1, temp) = "" Then
tabellen(1, temp) = "x"
tabspeicher(temp + 1) = 1
tabspeicher(0) = tabspeicher(0) + 1
doc.Tables(tab1).Range.copy
neu.Activate
wApp.Selection.Paste
doc.Tables(1).Rows.Alignment = wdAlignRowCenter
doc.Tables(1).Rows.WrapAroundText = False
wApp.Selection.EndKey Unit:=wdStory
wApp.Selection.TypeParagraph
doc.Activate
End If
If akttabelle = 1 Then
doc.Range(doc.Tables(tab1).Range.End, doc.Tables(tab1).Range.End).Select
wApp.Selection.TypeParagraph
End If
End If
Next akttabelle
wApp.Documents(doc).Close SaveChanges:=True
Next user
wApp.Documents(neu).Close SaveChanges:=False
wApp.Quit
Set wApp = Nothing
End Sub