Makro: Tabelle von Excel in Word Textmarken
29.05.2018 09:33:36
Excel
ich stehe vor einem Excel bzw. VBA Problem.
Ich habe ein fertiges Makro bekommen, um in einem geöffneten Word Dokument an Textmarken Tabellen aus Excel als Bild einzufügen.
Soweit so gut.
Nun befindet sich in meiner Excel Tabelle eine Liste in der Zelle A1 als Dropdown Menü. Diese Liste soll angesprungen werden und dann quasi jede Tabelle die sich hinter dem Begriff verbirgt, an den Textmarken eingefügt werden.
Ich hoffe es ist verständlich.
Aber: Es wird nur die jeweils angezeigte bzw. ausgewählte Tabelle als Bild eingefügt.
Ich möchte aber, dass alle Tabellen zu der kompletten Liste in Word eingefügt werden.
Es ist ein kleiner (Denk-)Fehler drin, an dem ich gerade verzweifle. Hier das Makro, im besten Fall würde ich gerne mit dem bestehenden Makro arbeiten und ggf. nur ergänzen:
Sub Word_Bericht_Textmarke()
' Word_Bericht_Textmarke Makro
Dim rng As Range
'Var = Application.Match("", Worksheets("Planungseinheiten").Range("B11:B149"), -1) - 1
Set rng = Worksheets("Planungseinheiten").Range("B11:B159")
a = Worksheets("Planungseinheiten").Range("B11:B159").SpecialCells(xlCellTypeBlanks).Count
'Debug.Print a
Dim arr() As String
ReDim arr(0 To 1, 0 To rng.Rows.Count - a - 1) ' Definiert eine Matrix mit 2 Spalten (0 to 1)
b = 0
For i = 11 To 159 ' Erstellt eine 2-spaltige Liste (Matrix) mit Planungseinheiten und _
Kurzbezeichnungen ohne Punkt
If Worksheets("Planungseinheiten").Range("B" & i) = "" Then
b = b + 1
Else
arr(0, i - 11 - b) = Worksheets("Planungseinheiten").Range("B" & i).Value
arr(1, i - 11 - b) = Left(Worksheets("Planungseinheiten").Range("A" & i).Value, 3) & Right( _
Worksheets("Planungseinheiten").Range("A" & i).Value, Len(Worksheets("Planungseinheiten").Range("A" & i).Value) - 4)
End If
Next i
'For i = 0 To rng.Rows.Count - a - 1
'Debug.Print arr(0, i) & " " & arr(1, i)
'Next i
'Exit Sub
Error_Personal = ""
Error_Bemessung = ""
On Error GoTo Text
If MsgBox("Word Dokument geöffnet? (Bsp. MED1_1 für Personal, MED1_2 für Berechnung als _
Textmarke", vbYesNo) = vbYes Then
GoTo Start
Else
GoTo Ende
End If
Worksheets("Personalblatt").Range("A1") = arr(0, i)
Application.ScreenUpdating = False
Start: For i = 0 To rng.Rows.Count - a - 1
Dim app As Object
Dim Slide As Object
Set app = GetObject(, "Word.Application") ' Wählt Worddokument in dem aktuell der Cursor _
steht
Application.ScreenUpdating = False
Sheets("Personalblatt").Select
Sheets("Personalblatt").Range("A2:F50").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set Slide = app.ActiveDocument
If Slide.Bookmarks.Exists(arr(1, i) & "_" & 1) = False Then
Error_Personal = Error_Personal & (arr(1, i) & "_" & 1) & " " ' Füllt die Variable ( _
Error_Personal) mit nicht vorhandenen Textmarken für das Personalblatt
Else
Slide.Bookmarks(arr(1, i) & "_" & 1).Select
Slide.Application.Selection.Paste
End If
line1:
Application.ScreenUpdating = False
Sheets("Bedarfsermittlung").Select
Sheets("Bedarfsermittlung").Range("A2:W91").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set Slide = app.ActiveDocument
If Slide.Bookmarks.Exists(arr(1, i) & "_" & 2) = False Then
Error_Bemessung = Error_Bemessung & (arr(1, i) & "_" & 2) & " " 'Chr(10)
Else
Slide.Bookmarks(arr(1, i) & "_" & 2).Select
Slide.Application.Selection.Paste
End If
'Anzahl = Slide.ActiveWindow.Selection.Information(3)
'MsgBox Anzahl
'Else
'GoTo line2
'End If
Next i
abox = MsgBox(Error_Personal, , "Fehlende Textmarken Personal")
bbox = MsgBox(Error_Bemessung, , "Fehlende Textmarken Bemessung")
Exit Sub
Application.ScreenUpdating = True
Text: MsgBox "Mach ein Word Dokument auf!"
Ende: End Sub