MS-Office-Forum
Google
   

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads Der Renner, 11 Entwicklertools für Access, Tipps & Trick und offene Datenbanken zum einzigartigen Preis.
Themen-Optionen Ansicht
Alt 11.01.2017, 10:27   #1
Raphael-2017
Neuer Benutzer
Neuer Benutzer
Standard VBA - Daten aus Excel nach Word transferieren

Hallo Excel-Foren-Mitglieder,

wie üblich, wenn hier jemand etwas schreibt, geht es um ein Problem das nicht (zumindest von mir) gelöst werden kann!

Informationen: das Problem besteht unter Windows 7 mit Excel 2013 ( 32 Bit ) und unter Windows 10 mit Excel 2016 ( 64 Bit ). Andere Systeme stehen mir nicht zur Verfügung.
Es handelt sich um eine .xlsm Excel-Datei.

Jetzt zu meinem Problem:
Ich habe hier eine Datei in welcher ich in jeder Zeile ein „Gerät“ eintrage und zu jedem dieser Geräte in die Spalten verschiedene Informationen ( insgesamt ca. 70 Spalten ). So z.B. Seriennummer / Equipmentnummer / Typ / wo verbaut / usw…..
Für jedes Gerät werden nun verschiedene Dokumente ausgedruckt. Bisher habe ich diese Dokumente „händisch“ ausgefüllt. Bei den Dokumenten handelt es sich sowohl um Excel- als auch um Word-Dokumente.
Jetzt war mein Gedanke dies zu Automatisieren.
Mein Wunsch wäre nun, dass ich in dem Exel-file auf eine beliebige Zelle klicke und nun via Makro die benötigten Informationen ( nenne wir Sie Typ / Equipmentnummer / Ort ) aus dieser Zeile kopiere, sich das Word-Formular öffnet und diese Informationen dort, an vordefinierten „Stellen“, eingefügt werden.
Leider schaffe ich es nicht die Daten aus Excel in das Word-Dokument zu bekommen.
Folgenden Code habe ich bis jetzt im Einsatz:
Code:

Public Function CE_Erklaerung()
'großer versuch
    Dim appWord         As Object
    Dim doc             As Object
    Dim wks             As Worksheet
    Dim WordObj         As Object
    Dim AdresseCE       As String
    Dim neueAdresseCE   As String 
    Dim EQNR As String
    
    '*** Tabelle aktivieren ***
    ThisWorkbook.Worksheets("CCS-2016").Activate

     '*** Aktive Zeile auslesen ***
    AdresseCE = ActiveCell.AddressLocal(False, False)
    neueAdresseCE = Mid(AdresseCE, 2)

    '*** Word starten ***
    Set appWord = CreateObject("Word.Application")
    
    '*** verwendet Datei nur als Vorlage ***
    'Set doc = appWord.Documents.Add("C:DeinPfadAngebot.doc")
    
    '*** öffnet die Datei selbst ***
    'Set doc = appWord.Documents.Open("file://rtlxsmb1.rt.de.bosch.com/share/tef7w/CCS/09_CE/00_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    Set doc = appWord.Documents.Open("E:120 - Maschinenbuch0_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    
    '***
    Set WordObj = GetObject(, "Word.Application")
    If WordObj Is Nothing Then
        Set WordObj = CreateObject("Word.Application")
        Else
    End If
        
    '*** Word sichtbar machen ***
    appWord.Visible = True
    
    '*** falls das Dokument geschützt ist ***
    'doc.Unprotect
    
    '*** Anspringen einer Textstelle in Word mittels Textmarke ***
    '*** Prüfen ob diese existiert ***
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "T" an Textmarke einfügen ***
    If WordObj.ActiveDocument.Bookmarks.Exists("EQNR") Then
        With WordObj.Selection
            .Goto what:=wdGoToBookmark, Name:="EQNR"
            .TypeText Worksheets("CCS-2016").Range("T" & neueAdresseCE).Value
        End With
        Else
        MsgBox "Die Textmarke [EQNR] ist nicht vorhanden"
    End If
    
    '*** Aufräumen ***
    Set WordObj = Nothing
 
End Function
Könnt Ihr mir hier bitte helfen? Das Problem ist, das die Daten nicht eingetragen werden bzw. an einer ganz anderen Stelle. Evtl. bin ich auch zu ungeschickt im Umgang mit Word. Das erstellen einer Textmarke will mir nicht gelingen, bzw. werden dorthin keine Daten geschrieben.
Wie können wir das Problem lösen.
Schon einmal vielen Dank für’s lesen und helfen.
P.S.: Da nichts im Leben umsonst ist, würde Ich auch eine gute Flasche Wein spenden ( sofern der Helfer ü18 ist ).

MfG
Raphael
Raphael-2017 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.01.2017, 10:46   #2
EarlFred
MOF Guru
MOF Guru
Standard

Hallo Raphael,

auch ohne Wein (aber tolles Angebot!):
Code:

Option Explicit

Public Function CE_Erklaerung()
'großer versuch
    Dim appWord         As Object 'Word-Instanz
    Dim wdDoc           As Object 'Word-Document
    Dim wdRng           As Object 'Word-Range
    
    Dim wks             As Worksheet
    Dim neueAdresseCE   As Long
    Dim EQNR As String
    
    '*** Tabelle aktivieren ***
    ThisWorkbook.Worksheets("CCS-2016").Activate 'wozu?

     '*** Aktive Zeile auslesen ***
    neueAdresseCE = ActiveCell.Column

    '*** Word starten ***
    Set appWord = CreateObject("Word.Application")
    
    '*** öffnet die Datei selbst ***
    Set wdDoc = appWord.Documents.Open("E:120 - Maschinenbuch0_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    
    '*** Word sichtbar machen ***
    appWord.Visible = True
    
    '*** falls das Dokument geschützt ist ***
    'doc.Unprotect
    
    '*** Anspringen einer Textstelle in Word mittels Textmarke ***
    '*** Prüfen ob diese existiert ***
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "T" an Textmarke einfügen ***
    If wdDoc.Bookmarks.Exists("EQNR") Then
        With wdDoc.Bookmarks("EQNR")
            Set wdRng = .Range
            wdRng.Text = Worksheets("CCS-2016").Range("T" & neueAdresseCE).Value
            wdDoc.Bookmarks.Add "EQNR", wdRng
        End With
    Else
        MsgBox "Die Textmarke [EQNR] ist nicht vorhanden"
    End If
    
    
    
    
    '*** Aufräumen ***
    
    'Dokument speichern? Schließen? App schließen?
    
    
    Set wdRng = Nothing
    Set wdDoc = Nothing
    Set appWord = Nothing
End Function
Die Backslashs \ werden hier verschluckt - bitte wieder eintragen.

Grüße
EarlFred
EarlFred ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.01.2017, 16:54   #3
Raphael-2017
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo EarlFred,

danke für's Lesen. Hier der Code mit den fehlenden Backslashes.
Code:

Public Function CE_Erklaerung()
'großer versuch
    Dim appWord         As Object
    Dim doc             As Object
    Dim wks             As Worksheet
    Dim WordObj         As Object
    Dim AdresseCE       As String
    Dim neueAdresseCE   As String 
    Dim EQNR As String
    
    '*** Tabelle aktivieren ***
    ThisWorkbook.Worksheets("CCS-2016").Activate

     '*** Aktive Zeile auslesen ***
    AdresseCE = ActiveCell.AddressLocal(False, False)
    neueAdresseCE = Mid(AdresseCE, 2)

    '*** Word starten ***
    Set appWord = CreateObject("Word.Application")
    
    '*** verwendet Datei nur als Vorlage ***
    'Set doc = appWord.Documents.Add("C:/DeinPfad/Angebot.doc")
    
    '*** öffnet die Datei selbst ***
    'Set doc = appWord.Documents.Open("file://rtlxsmb1.rt.de.bosch.com/share/tef7w/CCS/09_CE/00_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    Set doc = appWord.Documents.Open("E:/120 - Maschinenbuch/00_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    
    '***
    Set WordObj = GetObject(, "Word.Application")
    If WordObj Is Nothing Then
        Set WordObj = CreateObject("Word.Application")
        Else
    End If
        
    '*** Word sichtbar machen ***
    appWord.Visible = True
    
    '*** falls das Dokument geschützt ist ***
    'doc.Unprotect
    
    '*** Anspringen einer Textstelle in Word mittels Textmarke ***
    '*** Prüfen ob diese existiert ***
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "T" an Textmarke einfügen ***
    If WordObj.ActiveDocument.Bookmarks.Exists("EQNR") Then
        With WordObj.Selection
            .Goto what:=wdGoToBookmark, Name:="EQNR"
            .TypeText Worksheets("CCS-2016").Range("T" & neueAdresseCE).Value
        End With
        Else
        MsgBox "Die Textmarke [EQNR] ist nicht vorhanden"
    End If
    
    '*** Aufräumen ***
    Set WordObj = Nothing
 
End Function
Hoffentlich bleiben Sie diesesmal sichtbar. Im "Modul" sind Sie jedenfalls vorhanden. :-)

Das Angebot steht auf alle fälle und ist auch ernst gemeint ( das mit dem Wein ) .
Raphael-2017 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.01.2017, 07:53   #4
Raphael-2017
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo EarlFred,

ich dummkopf, habe Deine Antwort nicht verstanden ... das liebe alter.

Vielen lieben Dank ... werde esgleich testen ... mea culpa

LG
Raphael
Raphael-2017 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.01.2017, 08:26   #5
Raphael-2017
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard Nachfrage ob dies so stimmt!

Hallo nochmal,

Dein Code funktioniert hervorragend.
Vielen Dank dafür.
Wenn Du mir Deine Adresse gibst, sende ich Dir gerne die Falsche Wein oder Ramazotti oder eine große Tüte Gummibären zu :-)

Jetzt hast Du mich auf den Geschmack gebracht das ganze weiter zu Optimieren. Evtl. könntst Du mir dabei etwas helfen.

Die Word Datei soll ausgedruckt werden und danach ohne zu speichern geschlossen werden.

Code:

Public Function CE_Erklaerung()

    Dim appWord         As Object 'Word-Instanz
    Dim wdDoc           As Object 'Word-Document
    Dim wdRngE          As Object 'Word-Range
    Dim wdRngR          As Object
    Dim wdRngC          As Object
    Dim wdRngCN         As Object
    
    Dim wks             As Worksheet
    Dim AdresseCE       As String
    Dim neueAdresseCE   As Long
    Dim EQNR            As String
    Dim RPAM            As String
    Dim CCS             As String
    Dim CCSNR           As String
    
    '*** Tabelle aktivieren ***
    'ThisWorkbook.Worksheets("CCS-2016").Activate 'wozu? ---- gute frage, auf die ich keine Antwort habe. Dachte immer das wäre nötig.

     '*** Aktive Zeile auslesen ***
    'neueAdresseCE = ActiveCell.Column ' ich benötige nur die Zeilen-Nummer ohne die Spaltenbezeichnung
     AdresseCE = ActiveCell.AddressLocal(False, False)
     neueAdresseCE = Mid(AdresseCE, 2)

    '*** Word starten ***
    Set appWord = CreateObject("Word.Application")
    
    '*** öffnet die Datei selbst ***
    Set wdDoc = appWord.Documents.Open("J:120 - Maschinenbuch0_Vorlage_2016_CCS_Konformitätserklärung_TEST.docm")
    
    '*** Word sichtbar machen ***
    appWord.Visible = True
    
    '*** falls das Dokument geschützt ist ***
    'doc.Unprotect
    
    '*** Anspringen einer Textstelle in Word mittels Textmarke ***
    '*** Prüfen ob diese existiert ***
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "T" an Textmarke einfügen ***
    If wdDoc.Bookmarks.Exists("EQNR") Then
        With wdDoc.Bookmarks("EQNR")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CCS-2016").Range("T" & neueAdresseCE).Value
            wdDoc.Bookmarks.Add "EQNR", wdRngE
        End With
    Else
        MsgBox "Die Textmarke [EQNR] ist nicht vorhanden"
    End If
    
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "G" in Textmarke "RPAM" einfügen ***
    If wdDoc.Bookmarks.Exists("RPAM") Then
        With wdDoc.Bookmarks("RPAM")
            Set wdRngR = .Range
            wdRngR.Text = Worksheets("CCS-2016").Range("G" & neueAdresseCE).Value
            wdDoc.Bookmarks.Add "RPAM", wdRngR
        End With
    Else
        MsgBox "Die Textmarke [RPAM] ist nicht vorhanden"
    End If
    
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "J" in Textmarke "CCS" einfügen ***
    If wdDoc.Bookmarks.Exists("CCS") Then
        With wdDoc.Bookmarks("CCS")
            Set wdRngC = .Range
            wdRngC.Text = Worksheets("CCS-2016").Range("J" & neueAdresseCE).Value
            wdDoc.Bookmarks.Add "CCS", wdRngC
        End With
    Else
        MsgBox "Die Textmarke [CCS] ist nicht vorhanden"
    End If
    
    '*** Den Wert aus Tabelle "CCS-2016" Zelle "E" in Textmarke "CCS-Nr" einfügen ***
    If wdDoc.Bookmarks.Exists("CCSNR") Then
        With wdDoc.Bookmarks("CCSNR")
            Set wdRngCN = .Range
            wdRngCN.Text = Worksheets("CCS-2016").Range("E" & neueAdresseCE).Value
            wdDoc.Bookmarks.Add "CCS", wdRngCN
        End With
    Else
        MsgBox "Die Textmarke [CCSNR] ist nicht vorhanden"
    End If
    
    '*** Aufräumen ***
    
    'Dokument speichern? Schließen? App schließen?
    'drucken??????
    'doc.Close '*** das Dokument schließen ohne zu speichern ***
    'appWord.Quit '*** Word beenden ***
    
    Set wdRngE = Nothing
    Set wdRngR = Nothing
    Set wdRngC = Nothing
    Set wdRngCN = Nothing
    Set wdRng = Nothing
    Set wdDoc = Nothing
    Set appWord = Nothing
    
End Function
Habe den Code etwas angepasst. Danke nochmals fürs Lesen und Helfen.

LG
Raphael
Raphael-2017 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.01.2017, 10:07   #6
EarlFred
MOF Guru
MOF Guru
Standard

Hallo Raphael,

vielen Dank für das Angebot. Es mangelt mir weder an Wein, Ramazotti noch Gummibärchen - aber ich finde es toll, dass Du eine Gegenleistung überhaupt anbietest. Wenn Du wirklich was gutes tun willst, spende das gleiche Geld lieber, z. B. an Wikipedia oder die Tafel in Deiner Stadt.

Ungetestet:
Code:

    'Dokument speichern? Schließen? App schließen?
    'drucken??????
    'doc.Close '*** das Dokument schließen ohne zu speichern ***
    'appWord.Quit '*** Word beenden ***
 
    wdDoc.PrintOut
    wdDoc.Close savechanges:=False
    appWord.Quit
Grüße
EarlFred
EarlFred ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.01.2017, 10:44   #7
Raphael-2017
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo EarlFred,

vielen lieben Dank für Deine Unterstützung.
Dir und Deiner Familie eine gute Zeit und vor allem Gesundheit.

Die Tafeln bekommen von uns 1x Quartal eine Zuwendung (Sachspenden).

Werde den Betrag an den Verein "hilfe für Krebskranke Kinder" spenden.

LG und ein schönes Wochenende
Raphael
Raphael-2017 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 07:53 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.

Copyright ©2000-2010 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günther Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.
Beachten Sie bitte auch unsere Nutzungsbedingungen.