Hallo Zusammen, gibt es eine Möglichkeit die Zahlen in der Spalte P in der Excel-Datei im Anhang genau in der gleichen Item-Reinfolge von Excel in der Word-Datei zu übertragen in den jeweiligen definierten Textmarken? Zudem wäre es noch so, wenn in der Spalte P keine Zahl steht, soll er die Zahl in Spalte E automatisch nehmen und dann auch in den jeweiligen Textmarker einfügen. (OP Wert von Spalte E (Excel) in Textmarker im Bereich OP (Word))
Da die Struktur der Items in der Excel-Datei und der Word-Datei immer gleich sind (Item 1 dann Item 2 usw.) sollen die Daten von oben nach unten in den jeweiligen Textmarkern eingetragen werden. Zudem wäre es auch Super, wenn ich die Summe in Spalte Q in den definierten Textmarker Summe übertragen kann. Dieser Textmarker kann auch immer Summe heißen. Das Problem ist die Summe in Spalte Q kann sich immer in einer anderen Zeile befinden, einmal kann Sie in Zeile 67 stehen oder in eine andere Zeile befinden, aber immer in Spalte Q. Die Summe liegt aber immer gegenüber des Textes Gesamt: in der Spalte O. Vielleicht kann man da eine Verbindung programmieren: Suche Gesamt: in Spalte O und Trage dann in der Spalte Q den Wert in der gleiche Zeile in den Textmarker Summe in der Word-Datei ein.
Die Datei soll bei jeder Makroaktivierung (Button Übertragen von Daten an Word) als neu Datei gespeichert werden. Die alte Datei soll aber noch vorhanden bleiben. Zudem soll der Dateiname von der Zelle C3 übernommen werden.
Gibt es auch eine Möglichkeit, falls die Word-Datei verschoben wurde, dass automatisch sich ein Fenster in Excel öffnet und man dann den neuen Pfad vorgeben kann, wo die Datei liegt.
Ist es möglich das die Textmarker immer den gleichen Namen haben kann aber trotzdem die unterschiedlichen Werte der jeweiligen Items übernimmt von Excel?
Ich hab emein bestes versucht aber ich ahbe es nur soweit geschaft:
Sub ÜbertragungvonDateninWord()
'Bibliothek aktivieren
Dim wordapp As New Word.Application Dim doc As Word.Document
'Word sichtbar machen wordapp.Visible = True
'Word-Datei öffnen Set doc = wordapp.Documents.Open("C:\Users\Kluge\Desktop\Word-Muster.docx")
'Wenn die Datei nicht gefunden wird, soll die möglichkeit bestehen den Pfad bei Excel neu einzugeben in eine Suchfenster
Ich habe das so angelegt, dass die Bookmarks erhalten bleiben. Somit ist bei versehentlichen Speichern sichergestellt, dass die Bookmarks erhalten bleiben.
deine Makro ist für mich wirklich beindrucken. Danke das du mir Hilfst. Ich hätte noch 2 Fragen:
1.Ist es möglich, dass beim Drücken des Buttons (Übertragung von Daten an Word) das sich ein Fenster öffnet, wo ich die Word-Datei auswählen kann wo dann die Daten übertragen werden können zu den Textmarken? 2.Mir ist aufgefallen, wenn ich eine neue Position einfüge, dass das Makro ab der neuen eingefügten Position nicht die Daten weiter in den nachfolgenden Positionen in der Word-Datei überträgt. Ist es möglich das das Makro die Daten von Spalte P bzw. Spalte E von oben nach unten in der Word-Datei überträgt. Unabhängig davon, wie die Textmarken benannt wurden. Die Positionen von der Excel-Datei sind immer in der gleichen Reinfolge wie in Word.(Diese Items können von 1 bis 300 variieren von der Anzahl) Im Anhang befindet sich die neue Excel-Datei-Version 1 mit der neu hinzugefügten Item 5 und die Word-Datei-Version 1 mit dem neuen Item 5. Da kann man sehen, dass ab Item 4 die Daten nicht mehr übertragen wurden. Kann man da was machen?
zu 1. Das ist problemlos möglich. Der Pfad ist ein String und der kann im Dateifenster in die Variable Pfad übergeben werden.
beispielhaft so:
Code:
Sub PfadEinlesen() Dim pfad With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = False .Show pfad = .SelectedItems.Item(1) End With End Sub
Dazu gibt es jede Menge Beispiele im Netz.
zu 2. Das ist schon umsetzbar. Dazu wirst du aber zu folgenden Vorgehensweise gezwungen sein:
In sämtlichen dafür verwendeten Worddateien alle Marker von oben nach unten durchnummeriert neu anlegen nach dem Prinzip Marke1,Marke2 usw. (viel Fleißarbeit) In deiner Beispieldatei ist an dieser Stelle Kraut und Rüben los: 2 Marker an der gleichen Stelle (einer davon ohne Bedeutung für diesen Vorgang)
- Worddatei öffnen --> alle darin enthaltenen Marker auslesen und ins Array arrTM packen. Das geht beispielhaft ausgehend die vorhandenen Prozedur von mir so:
Code:
Dim arrMarkers() With wdDok.Bookmarks ReDim arrMarkers(1 To .Count) For i = 1 To .Count arrMarkers(i) = wdDok.Range.Bookmarks(i) Next i End With
danke für dein Antwort. Das hört sich ganz schön kompliziert an. Das übersteigt bei weiten mein Wissen über VBA.
zu Punkt 1: Ich bekomme es leider nicht hin den Code mit deiner Makro zu verbinden. Er zeigt mir da immer einen Fehler. Kannst du mir zeigen wie ich den Code in deiner vorhanden Makro in der Excel-Datei implementieren kann?
zu Punkt 2:
Du hast vollkommen recht das die Textmarker komplett durcheinander sind. Ich gehe immer so vor, dass ich vorgeschrieben Muster habe und diese in Word per Text aus Datei einfüge. Somit ist es eigentlich immer so das die Textmarker immer in unterschiedlicher reinfolge in der Word-Datei sich befinden. z.B. VKPreis3 ist bei Item 1 und VKPreis5 ist bei Item 2 Ich weiß nicht ob ich das richtig vertsanden habe was du zu diesem Punkt geschrieben hast. Ist es so dass ich bevor ich die Makro in Excel mit den Button betätige, muss ich vorher die Word-Datei öffnen und diese Makro in Word aktivieren: Dim arrMarkers() with wdDok.Boomarks ReDim arrMarkers (1 To. Count) For i= To. Count arrMarkers(i) = wdDok.Range Bookmarks(i) next i End With
Damit merkt er sich die Reinfolge der Textmarker z.B. VKPreis25 VKPreis 20 von oben nach unten und überträgt dann beim Betätigen des Buttons in der Excel-Datei die Werte von oben nach unten in die Word-Datei?
Es tut mir leid, wenn ich dir nicht so gut folgen kann.
ich habe es mal so gebaut, dass es Wurst ist in welcher Abfolge die Marker und dessen Namen angelegt wurden. Des Weiteren ist es jetzt egal wie viel Zeilen zwischen den Items sich befinden. Benutzt habe ich die Dateien aus #3 Dann kannst du die zu bearbeitende Datei im Dateifenster wählen.
Code:
Option Explicit
Sub ÜbertragungvonDateninWord() Dim Pfad$, lz&, i&, j&, arrWerte(), arrTM(), arrItem(), Sum As Variant Dim WdApp As Object, wdDok As Object, objBkm As Object, rngBkm As Object With Tabelle1 lz = .Cells(Rows.Count, 2).End(xlUp).Row For i = 1 To lz + 20 If Mid(.Cells(i, 2), 1, 4) = "Item" Or .Cells(i, 2) = "OP" Then j = j + 1 ReDim Preserve arrItem(1 To j) arrItem(j) = i End If Next i Sum = Application.Match("Gesamt:", .Columns("O"), 0) If Not IsError(Sum) Then ReDim Preserve arrItem(1 To j + 1): arrItem(j + 1) = Sum End With j = 0 ChDir ActiveWorkbook.Path With Application.FileDialog(msoFileDialogOpen) .Title = "Auswahl der Worddatei" .AllowMultiSelect = False .Filters.Clear .Filters.Add "Word-Dateien", "*.do*" .Show If .SelectedItems.Count = 0 Then Exit Sub Pfad = .SelectedItems.Item(1) End With
Set WdApp = CreateObject("Word.Application") Set wdDok = WdApp.Documents.Open(Filename:=Pfad, ReadOnly:=False) WdApp.Visible = True With wdDok.Bookmarks ReDim arrTM(0 To .Count - 1) For i = 0 To .Count - 1 arrTM(i) = wdDok.Range.Bookmarks(i + 1) Next i End With
With Tabelle1 ReDim arrWerte(1 To UBound(arrItem)) arrWerte(1) = .Range("C3") For i = 2 To UBound(arrItem) - 1 If .Cells(arrItem(i), 16) <> "" Then arrWerte(i) = Format(.Cells(arrItem(i), 16), "#,##0.00") Else arrWerte(i) = Format(.Cells(arrItem(i), 5), "#,##0.00") End If Next i arrWerte(i) = Format(.Cells(arrItem(i), 17), "#,##0.00") End With
For i = 0 To UBound(arrTM) - 1 With wdDok Set objBkm = .Bookmarks(arrTM(i)) Set rngBkm = objBkm.Range rngBkm.Text = arrWerte(i + 1) .Bookmarks.Add Name:=arrTM(i), Range:=rngBkm End With Next i Set wdDok = Nothing Set WdApp = Nothing End Sub
das funktioniert wirklich super, wenn ich auf den Button klicke öffnet sich ein Fenster wo ich die Word-Datei wählen kann. Danke dir. Das ist für mich wirklich beeindruckend. Ich möchte mich nochmal wirklich für deine Zeit bedanken das du mir Hilfst.
Es sind mir leider noch zwei Sachen aufgefallen die mein Fehler waren weil ich das nicht richtig an dir kommuniziert habe, sorry: Ich habe auch den Marker mit den Dateinamen entfernt. Ist nicht mehr notwendig. Jetzt hat er aber folgendes gemacht: In Item 1) steht nicht die 10 sondern eine Dateiname. Kann man das noch Ändern.
Die Summe übernimmt er leider nicht: Die Summe kann immer in einer anderen Zeile sich befinden wenn neue Zeilen eingefügt werden. Kann man das so machen, nur die Zahl in Spalte Q nehmen wenn der Text Gesamt: in der gleichen Zeile steht? Die Marke kann in Word auch immer Summe heißen. Diese verändert sich nicht wie die anderen VKPreise in den Namen.
Zeile 42 auskommentieren und Zeile 43 den Zählbereich so ändern:
Code:
For i = 1 To UBound(arrItem) - 1
angepasst mit Hinweisen in den beiden Zeilen:
Code:
Option Explicit
Sub ÜbertragungvonDateninWord() Dim Pfad$, lz&, i&, j&, arrWerte(), arrTM(), arrItem(), Sum As Variant Dim WdApp As Object, wdDok As Object, objBkm As Object, rngBkm As Object With Tabelle1 lz = .Cells(Rows.Count, 2).End(xlUp).Row For i = 1 To lz + 20 If Mid(.Cells(i, 2), 1, 4) = "Item" Or .Cells(i, 2) = "OP" Then j = j + 1 ReDim Preserve arrItem(1 To j) arrItem(j) = i End If Next i Sum = Application.Match("Gesamt:", .Columns("O"), 0) If Not IsError(Sum) Then ReDim Preserve arrItem(1 To j + 1): arrItem(j + 1) = Sum End With j = 0 ChDir ActiveWorkbook.Path With Application.FileDialog(msoFileDialogOpen) .Title = "Auswahl der Worddatei" .AllowMultiSelect = False .Filters.Clear .Filters.Add "Word-Dateien", "*.do*" .Show If .SelectedItems.Count = 0 Then Exit Sub Pfad = .SelectedItems.Item(1) End With
Set WdApp = CreateObject("Word.Application") Set wdDok = WdApp.Documents.Open(Filename:=Pfad, ReadOnly:=False) WdApp.Visible = True With wdDok.Bookmarks ReDim arrTM(0 To .Count - 1) For i = 0 To .Count - 1 arrTM(i) = wdDok.Range.Bookmarks(i + 1) Next i End With
With Tabelle1 ReDim arrWerte(1 To UBound(arrItem)) 'arrWerte(1) = .Range("C3") 'falls wieder benötigt dann die Auskommentierung rausnehmen For i = 1 To UBound(arrItem) - 1 ' falls Dateiname wieder benötigt wird dann For i = 2 To UBound(arrItem) - 1 If .Cells(arrItem(i), 16) <> "" Then arrWerte(i) = Format(.Cells(arrItem(i), 16), "#,##0.00") Else arrWerte(i) = Format(.Cells(arrItem(i), 5), "#,##0.00") End If Next i arrWerte(i) = Format(.Cells(arrItem(i), 17), "#,##0.00") End With
For i = 0 To UBound(arrTM) With wdDok Set objBkm = .Bookmarks(arrTM(i)) Set rngBkm = objBkm.Range rngBkm.Text = arrWerte(i + 1) .Bookmarks.Add Name:=arrTM(i), Range:=rngBkm End With Next i Set wdDok = Nothing Set WdApp = Nothing End Sub
Daten aus Excel automatisiert in Word einfügen
