Word Makro
31.03.2017 08:29:10
Urs
Möchte aus einem Word-Makro entsprechende Tabellen nach Excel kopieren. Der grösste Teil habe ich bereits von diesem Forum (Michael sei Dank!). Nun möchte ich, dass die Tabellen untereinander hineinkopiert werden und zwar eben direkt aus dem Word Makro. Jetzt überschreibt er das Ganze, was eben nicht so toll ist.
Danke im Voraus für die Hilfe.
Grüsse
Urs
'Word-Makro
Dim goaltbl As Long
Dim infotbl As Long
Sub request()
Call BLA(3, 4) 'wenn 1 Produkt
Call BLA(6, 7) 'wenn 2 Produkte
Call BLA(9, 10) 'wenn 3 Produkte
Call BLA(12, 13) 'wenn 4 Produkte
Call BLA(15, 16) 'wenn 5 Produkte
End Sub
Function BLA(infotbl As Long, goaltbl As Long)
If infotbl = 0 Then
goaltbl = 3
infotbl = 4
Dim wPfad As String, xPfad As String ' Word- und Excel-Pfad
Dim wDatei As String, xDatei As String ' Word- und Excel- _
Dateiname
Dim dirDatei As String ' Dateiname für Dir- _
Befehl
Dim a(), b(), i&, aMax&, j& ' Durchlaufen der _
Content Controls
Dim o As Object, oo ' Wenn Word Datei _
existiert setze o
Dim ExcelSheet As Object ' ExcelSheet als Objekt _
_
definiert
Dim shl As Object ' Objektzuordnung
Dim strFilenameFull As String ' Pfad und Datei _
zusammen
Dim r As Row, s As Row ' Varaible Wordtabelle _
_
auslesen
Dim cL As Cell ' Variable Zellen Zä _
hler
Dim strWorkbook As String ' Variable Excel-Datei
Dim counter As Long ' Variable Zähler
Dim appExcel As Object ' Variable Excel _
Applikation
Dim sWorkbook As Object ' Variable Excel-Datei _
_
evtl. doppelt!
Dim Start As Single
Dim Pause As Integer, Pausenlänge As Integer
Set shl = CreateObject("Shell.Application") ' Zuordnung .......
'ExcelObject erstellen
Set appExcel = CreateObject("Excel.Application") ' Erstellt Excel Objekt
wPfad = "L:\Makros\LEH\LEH_Datenablage\Führungsinstrumente\" ' Datenpfad Dokumente
xPfad = "L:\Makros\LEH\LEH_Datenablage\" ' Datenpfad Excel _
Ablage
xDatei = "ImportAusWord.xlsm" ' Excel-Datei
wDatei = ActiveDocument ' Aktives Dokument
strFilenameFull = xPfad & xDatei ' Zuordnung Pfad und _
Datei
dirDatei = Dir(wPfad & wDatei & "*.docx") ' Findet Word Datei im _
_
Pfad
If dirDatei "" Then Set o = CreateObject("scripting.dictionary") ' Wenn Word Datei _
existiert setze o + markiere
With Documents(wDatei) ' ..öffnet das Dokument
ReDim a(1 To 1, 1 To .ContentControls.Count) ' *** ContentControls. _
_
Coun Zähler
For i = 1 To .ContentControls.Count ' Abfrage Zähler Ende
a(1, i) = .ContentControls(i).Range.Text ' *** Durchlaufen der _
_
Contents
Next i ' Schleife
End With ' Ende Schleife
If UBound(a, 2) > aMax Then aMax = UBound(a, 2) ' Die höchste _
Spaltenanzahl ermitteln
i = 0
i = i + 1 ' Zähler
With CreateObject("excel.application").workbooks.Open(xPfad & xDatei) ' Pfad und Datei _
erstellt ***** öffnet Excel-Datei
.Sheets("Dok").Range("A2").Resize(i, aMax + 1) = a ' Ab A2 wegen Ü _
berschriften
Application.DisplayAlerts = False
.Save ' speichert
.Close ' schliesst
Application.DisplayAlerts = True
End With
strWorkbook = FileAuswaehlen ' Sprung zur Funktion
Set sWorkbook = appExcel.workbooks.Open(strFilenameFull) ' Zuornung sWorkbook ** _
_
*** öffnet Excel-Datei
counter = sWorkbook.ActiveSheet.Cells(sWorkbook. _
ActiveSheet.Rows.Count, 1).End(-4162).Row ' bis ans Ende zählen
'Wordtabelle auslesen
counter = 0
For Each r In ActiveDocument.Tables(infotbl).Rows ' Wordatei Tabellen _
bestimmen
counter = counter + 1 ' Aufzählen
i = 0
For Each cL In r.Cells
i = i + 1
' Register "Tab3"
sWorkbook.Sheets("Tab3").Cells(counter, i) _
= Left(cL.Range.Text, Len(cL.Range.Text) - 1) ' Wird ins Register " _
Tab3" geschrieben
Next
Next
'Wordtabelle auslesen
counter = 0
For Each s In ActiveDocument.Tables(goaltbl).Rows ' Wordatei Tabellen _
bestimmen
counter = counter + 1 ' Aufzählen
i = 0
For Each cL In s.Cells
i = i + 1
' Register "Tab4"
'sWorkbook.Sheets("Tab4").Range("A1").Cells(counter, i) _
= Left(cL.Range.Text, Len(cL.Range.Text) - 1)
sWorkbook.Sheets("Tab4").Cells(counter, i) _
= Left(cL.Range.Text, Len(cL.Range.Text) - 1) ' Wird ins Register " _
Tab4" geschrieben
Next
Next
On Error GoTo DispFehler ' Fehlarabfrage
Application.DisplayAlerts = False ' Display inaktiv
'ExcelDatei schliessen
shl.Save xPfad & xDatei ' Excel-Datei _
gespeichert
DispFehler:
Application.DisplayAlerts = True ' Display aktiv
'shl.Open xPfad & xDatei ' Öffnet die Excel- _
Datei
'Pausenlänge = 3
'Start = Timer
'Do While Timer
Function ' Ende Function
Function FileAuswaehlen() As String
Dim dlgOpen As FileDialog ' Variable abfüllen
Set dlgOpen = Application. _
FileDialog(FileDialogType:=msoFileDialogOpen) ' Zuordnung dlgOpen
With dlgOpen ' Schleife Beginn
.AllowMultiSelect = False ' Meldungsfelder _
inaktiv
.Filters.Clear ' löscht Filter
.Filters.Add "Excel Dateien", "*.xls*", 1 ' Filter "Excel Dateien" _
_
aktiv
End With ' Schleife Ende
If dlgOpen.SelectedItems.Count 1 Then ' Wenn dlgOpen Zähler _
_
1 dann...
Exit
Function ' ...Ende Function
End If ' Beendet
FileAuswaehlen = dlgOpen.SelectedItems(1) ' FileAuswahlen = _
dlgOpen selektioniert
End
Function