Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1548to1552
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Word Makro

Word Makro
31.03.2017 08:29:10
Urs
Hallo Leute
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



		

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Word Makro
01.04.2017 10:57:39
Michael
Hi,
das ist wegen der Kommentare bzw. Zeilenumbrüche so unlesbar...
Kannst Du mal den link vom damaligen Thread einfügen (oder hast Du Tag/Zeit)?
Gruß,
Michael
AW: Word Makro
04.04.2017 08:52:36
Urs
Hallo Michael
Danke für deine Hilfe. Ich habe es erneut unten eingefügt, jetzt ohne Kommentar.
'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
' ...... geht weiter bis Call BLA(72, 73)
End Sub
Function BLA(infotbl As Long, goaltbl As Long)
If infotbl = 0 Then
goaltbl = 3
infotbl = 4
End If
Dim wPfad As String, xPfad As String
Dim wDatei As String, xDatei As String
Dim dirDatei As String
Dim a(), b(), i&, aMax&, j&
Dim o As Object, oo
Dim ExcelSheet As Object
Dim shl As Object
Dim strFilenameFull As String
Dim r As Row, s As Row
Dim cL As Cell
Dim strWorkbook As String
Dim counter As Long
Dim appExcel As Object
Dim sWorkbook As Object
Dim Start As Single
Dim Pause As Integer, Pausenlänge As Integer
Set shl = CreateObject("Shell.Application")
'ExcelObject erstellen
Set appExcel = CreateObject("Excel.Application")
wPfad = "L:\Makros\LEH\LEH_Datenablage\Führungsinstrumente\"
xPfad = "L:\Makros\LEH\LEH_Datenablage\"
xDatei = "ImportAusWord.xlsm"
wDatei = ActiveDocument
strFilenameFull = xPfad & xDatei
dirDatei = Dir(wPfad & wDatei & "*.docx")
If dirDatei  "" Then Set o = CreateObject("scripting.dictionary")
With Documents(wDatei)
ReDim a(1 To 1, 1 To .ContentControls.Count)
For i = 1 To .ContentControls.Count
a(1, i) = .ContentControls(i).Range.Text
Next i
End With
If UBound(a, 2) > aMax Then aMax = UBound(a, 2)
i = 0
i = i + 1
With CreateObject("excel.application").workbooks.Open(xPfad & xDatei)
.Sheets("Dok").Range("A2").Resize(i, aMax + 1) = a
Application.DisplayAlerts = False
.Save
.Close
Application.DisplayAlerts = True
End With
strWorkbook = FileAuswaehlen
Set sWorkbook = appExcel.workbooks.Open(strFilenameFull)
counter = sWorkbook.ActiveSheet.Cells(sWorkbook. _
ActiveSheet.Rows.Count, 1).End(-4162).Row
'Wordtabelle auslesen
counter = 0
For Each r In ActiveDocument.Tables(infotbl).Rows
counter = counter + 1
i = 0
For Each cL In r.Cells
i = i + 1
' Register "Tab3"
sWorkbook.Sheets("T3").Cells(counter, i) _
= Left(cL.Range.Text, Len(cL.Range.Text) - 1)
Next
Next
'Wordtabelle auslesen
counter = 0
For Each s In ActiveDocument.Tables(goaltbl).Rows
counter = counter + 1
i = 0
For Each cL In s.Cells
i = i + 1
' Register "T4"
sWorkbook.Sheets("T4").Cells(counter, i) _
= Left(cL.Range.Text, Len(cL.Range.Text) - 1)
Next
Next
On Error GoTo DispFehler
Application.DisplayAlerts = False
'ExcelDatei schliessen
shl.Save xPfad & xDatei
DispFehler:
Application.DisplayAlerts = True
sWorkbook.Close savechanges:=True
'ExcelObject löschen
Set appExcel = Nothing
End Function
Function FileAuswaehlen() As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application. _
FileDialog(FileDialogType:=msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel Dateien", "*.xls*", 1
End With
If dlgOpen.SelectedItems.Count  1 Then
Exit Function
End If
FileAuswaehlen = dlgOpen.SelectedItems(1)
End Function   

  • Anzeige
    AW: Word Makro
    04.04.2017 16:38:52
    Urs
    Hallo Michael
    Ich habe hier einmal ein Dokument und das fertige Excel wie es aussehen müsst im Upload. Vermutlich wird das nicht so einfach gehen. Bis jetzt habe ich dein Word-Makro benutzt und den Rest im Excel als zusätzliches Makro ausgeführt Sortierung, Duplikate entfernt, Bezeichnung heruntergezogen usw.). Vielleicht könnte man das eben direkt alles im Word-Makro realisieren. Wäre toll.
    Das Word ist Schreibgeschützt und die User können nur die ausgewählten Felder beschreiben. Der Text ist leider unterschiedlich lang. Die Tabellen sind dagegen immer gleich gross.
    Das Ziel wäre nun, wie im Excel dargestellt, dass in einem Register die Tabellen 3,6,9.... usw. und im anderen Register die Tabellen 4,7,10.... usw. untereinander dargestellt würden. Dabei müsste auch der Titel Produkt Kostenstelle : xxxxxxx Nr. bei dem jeweiligen Tabelle stehen.
    Anzeige
    AW: Word Makro
    04.04.2017 16:47:28
    Urs
    Danke im Voraus.
    bitte morgen....
    04.04.2017 17:42:34
    Michael
    Hi Urs,
    habe heute keine Zeit mehr, ich seh's mir morgen mal an...
    Schöne Grüße,
    Michael
    AW: Word Makro
    05.04.2017 07:44:12
    Urs
    Hallo Michael
    Kein Problem, bin schon froh, wenn du das einmal anschauen könntest.
    Gruss
    Urs
    AW: Word Makro
    05.04.2017 08:02:13
    Urs
    Hallo Michael
    Kein Problem, bin schon froh, wenn du das einmal anschauen könntest.
    Gruss
    Urs
    AW: Word Makro
    06.04.2017 07:46:55
    Urs
    Hi Michael
    Sorry das ich so stresse, aber wie sieht es aus, hast du eine Lösung? Ich müsste erste Resultate morgen Freitag vorweisen können. Ist mir schon klar, dass dies schwierig umsetzbar ist, aber vielleicht hast du ja eine zündende Idee. Wenn's dann gar nicht geht, wäre mir eine Teillösung in Form von Tabellen kopieren in nächste freie Zeile untereinander willkommen.
    Danke für die Geduld und die Arbeit.
    Anzeige
    Sorry, zu umfangreich: Word-VBA?!
    06.04.2017 16:41:17
    Michael
    Hallo Urs,
    der alte Thread war der hier:
    https://www.herber.de/cgi-bin/callthread.pl?index=1543765
    Da ging es darum, ein paar Werte aus "Feldern" auszulesen, mittlerweile sollen Daten aus Word-Tabellen zusammengesucht werden.
    Ich würde einige Stunden benötigen, um mich da überhaupt erst einzudenken, und die Programmierung dauert nochmal entsprechend: das geht nicht bis morgen und auch nicht als kostenloser Forumsbeitrag.
    Abgesehen davon frage ich mich, ob das Formular nicht einfacher ausgewertet werden kann, wenn man es gleich in Excel statt in Word erstellt...
    Wenn Du die ganze Geschichte als Programmierauftrag vergeben willst, kannst Du Dich gerne bei den Profilen im Forum umsehen: meines ist das hier: https://www.herber.de/cgi-bin/profile/call_profile.pl?user=1857094
    Ich stelle nochmal auf offen, habe aber wenig Hoffnung.
    Gutes Gelingen & schöne Grüße,
    Michael
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige