Moin! Also hat ein wenig gedauert. Musste schließlich noch arbeiten und dann wollte Word mal nicht so wie ich. Hatte zudem nochmal geschaut wegen dem aktualisieren. Also mE kann man dass in deinem Fall nicht machen. Es können wohl nur Exceltabellen, welche als ganzes Eingefügt sind aktualisiert werden. Einzelen Zellen geht nicht. Dein Vorschlag würde für Excel gehen. Da kann man Beziehungen auf andere Excelmappen machen und Excel holt sich die Daten. Beim MIx aus Word und Excel wird das aber nix. Falls es doch eine Möglichkeit gibt, kann man die natürlich mit einbauen. Alternativ müsstest du dann wie bei dem u.a. Code das manuell machen. Eigentlich braucht der Code dann ja keine Tabellen erstellen (oder halt nur schauen, ob es die Tabelle schon gibt) und die Werte in den Tabellen ändern. Da ich nicht genau wußte, wie dein Worddokument aussieht, hier mal mein Übungsdocument

http://www.herber.de/bbs/user/107050.doc

Und weil ich es ja letztens auch so schrieb, hier noch etwas Code zum Befüllen. Die Ausführung sollte in dem Excelblatt mit den DAten starten. Und setzt mal bitte beim Makro hinten im VBE den Verweis auf Word ( hießt etwa: Microsoft Word Zahl Obeject Library) . FAlls das nicht geht oder du das nicht willst, nochmal melden. Habe ein paar Word Bezeichner drin. Die müssten dann geändert werden - der Code sollte dann trotzdem laufen (glaube /  hoffe ich :-) ).

Zum Code noch. Der geht am Anfang deine Exceltabelle durch. Sucht sich die Tabellen raus und ordnet die Daten zu. Im Anschluß wird eine Vorlage geöffnet - dort den Pfad mal anpassen. Das ganze geht für deine Verantwortlichen (A bis J). Habe zum Testen aber nur einen DUrchlauf für A eingestellt. In der Vorlage wird Abschnit 2.1 gesucht und dort nach der Tabelle geschaut. (gehe davon aus, dass dort eine leere ist). Die leere wird zwischengespeichert. Und die ursp. gefüllt. Sollte der Verantwortliche noch eine Tabelle brauchen, wird die leere wieder reinkopiert und mit den Daten für Tabelle 2 gefüllt. Die gefüllten werden dann auch gespeichert - um sie ggf. bei anderen User nur noch einfügen zu müssen.

Soweit zum theoretischen. Hier der Code - mit wenigen Kommentaren. Bitte mal testen und ggf. rückmelden. Schönes Wochenende noch. VG

'Option Explicit

Sub übertragen()
Dim daten
Dim wApp As Object
Dim pfad As String

Dim doc As Object
Dim kap21da As Boolean
Dim kap21range As Long
Dim kap21folrange As Long
Dim kap As Object
Dim i As Long
Dim wzellen As Long



Dim tab1 As Long

Dim tabda As Boolean
Dim anztab As Long

Dim tabellen()
Dim verantwortliche()
Dim ende As Long
Dim zeile As Long
Dim user As Long
Dim speicherda As Boolean
Dim akttabelle As Long
Dim tabspeicher()

Dim titelzeile As Long

'###################Excel Tabelle auslesen########################################################
'prüfen wieviele Tabellen und wer verantwortlich ist.
'estellt,beteiligt etc.
ReDim tabellen(1 To 15, 0)
ReDim verantwortlich(10)
ReDim tabspeicher(0)

'letzter Eintrag in Spalte C
ende = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
For zeile = 7 To ende
    If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 0 Then titelzeile = zeile
    
    If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 1 And Left(ActiveSheet.Cells(zeile, 3), 1) <> "M" Then
        ReDim Preserve tabellen(1 To 15, UBound(tabellen, 2) + 1)
        'angelegt
        tabellen(1, UBound(tabellen, 2)) = ""
        'ap nummer
        tabellen(2, UBound(tabellen, 2)) = "AP " & ActiveSheet.Cells(titelzeile, 3)
        'Name
        tabellen(3, UBound(tabellen, 2)) = ActiveSheet.Cells(titelzeile, 4)
        'unter ap nr = ziel
        tabellen(4, UBound(tabellen, 2)) = "AP " & ActiveSheet.Cells(zeile, 3)
        'unter ap name = ziel
        tabellen(5, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 4)
        'verantwortlich
        tabellen(6, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 54)
        'mitarbeit
        tabellen(7, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 53)
        For user = 1 To 10
        'falls es mehr Nutzer werden hier ggf. anpassen
            If InStr(1, tabellen(7, UBound(tabellen, 2)), Chr(64 + user), vbTextCompare) > 0 Or InStr(1, tabellen(7, UBound(tabellen, 2)), Chr(96 + user), vbTextCompare) > 1 Then verantwortlich(user) = verantwortlich(user) & UBound(tabellen, 2) & ","
        Next user
        'bearbeitungszietraum
        tabellen(8, UBound(tabellen, 2)) = ActiveSheet.Cells(zeile, 52)
    End If
    
    If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 1 And Left(ActiveSheet.Cells(zeile, 3), 1) = "M" Then
        'meilensteine
        tabellen(9, UBound(tabellen, 2)) = tabellen(9, UBound(tabellen, 2)) & ActiveSheet.Cells(zeile, 3) & " " & ActiveSheet.Cells(zeile, 4) & Chr(10)
    End If
    
    If UBound(Split(ActiveSheet.Cells(zeile, 3), ".")) = 2 Then
        'Beschreibung
        tabellen(10, UBound(tabellen, 2)) = tabellen(10, UBound(tabellen, 2)) & ActiveSheet.Cells(zeile, 3) & " " & ActiveSheet.Cells(zeile, 4) & Chr(10)
    End If
    
Next zeile

ReDim Preserve tabspeicher(UBound(tabellen, 2) + 2)

'###########################Tabelle ausgelesen

Set wApp = CreateObject("Word.Application") 'Word als Object starten

speicherda = False

'alle Verantwortliche durchgehen und die Vorlage öffnen
For user = 1 To 1 ' max bis J dann bsi 10 einstellen 10

    'hier muss man noch die Pfade anpassen ggf. aus der Excelliste einlesen
    pfad = "C:\Users\ich\Desktop\umgebung\vorlage.doc"

    Set wApp = CreateObject("Word.Application") 'Word als Object starten
    wApp.Visible = True
    
    wApp.Documents.Open pfad
    
    Set doc = wApp.ActiveDocument
    
    kap21da = False
    kap21range = 0
    kap21folrange = doc.Range.End

    For Each kap In doc.Paragraphs
        If kap.OutlineLevel < 10 And kap.Range.Text <> Chr(13) Then
            If kap21da = True Then
                kap21folrange = kap.Range.Start
                Exit For
            End If
        
            If Left(kap.Range.Text, 3) = "2.1" Then
                kap21range = kap.Range.Start
                kap21da = True
            End If
        End If
    Next kap
    
    'nicht gefunden Meldung und Abbruch
    If kap21da = False Then
        MsgBox "Das Kapitel 2.1. wurde nicht gefunden. Das Programm wird beendet.", , "Kapitelfehler"
        wApp.Documents(pfad).Close SaveChanges:=True
        wApp.Quit
        Close
    End If

    'schauen ob es eine Tabelle gibt und die in 2.1 liegt
    tabda = False

    If doc.Tables.Count > 0 Then
        For anztab = 1 To doc.Tables.Count
        'prüfen ob da und wo sie liegt
            If doc.Tables(anztab).Range.Start > kap21range And doc.Tables(anztab).Range.Start < kap21folrange Then
                tabda = True
                tab1 = anztab
                Exit For
            End If
        Next anztab
    End If

    'Zwischenspeicher für die Tabellen laden
    If speicherda = False Then
        Set neu = wApp.Documents.Add
        speicherda = True
    End If
    
    If tabda = False Then
    'Tabelle basteln, habe ich mal weggelassen
    Else
    'sie ist leer dann zwicshenspeichern
        tabspeicher(0) = 1
        tabspeicher(1) = 1
        doc.Tables(tab1).Range.copy
        neu.Activate
        wApp.Selection.Paste
        wApp.Selection.EndKey Unit:=wdStory
        wApp.Selection.TypeParagraph
        neu.Tables(1).Rows.Alignment = wdAlignRowCenter
        neu.Tables(1).Rows.WrapAroundText = False
        doc.Activate
    End If
    'tabelle befüllen

    For akttabelle = 1 To UBound(Split(verantwortlich(user), ","))
        temp = Split(verantwortlich(user), ",")(akttabelle - 1)
        If IsNumeric(temp) = True And temp <> "" Then
            
            If tabellen(1, temp) = "" And akttabelle > 1 Then
                neu.Activate
                neu.Tables(1).Range.copy
                doc.Activate
                'wApp.Selection.EndKey Unit:=wdStory
                wApp.Selection.Paste
                tab1 = doc.Tables.Count
                doc.Range(doc.Tables(tab1).Range.End, doc.Tables(tab1).Range.End).Select
                wApp.Selection.TypeParagraph
            End If
            
            'eintragen
            'AP und Ttitel
            wApp.ActiveDocument.Tables(tab1).Cell(1, 1) = wApp.ActiveDocument.Tables(tab1).Cell(1, 1) & Chr(10) & tabellen(2, akttabelle) & " " & tabellen(3, akttabelle) & Chr(10) & tabellen(4, akttabelle) & " " & tabellen(5, akttabelle)
            'verantwoetlich
            wApp.ActiveDocument.Tables(tab1).Cell(1, 2) = wApp.ActiveDocument.Tables(tab1).Cell(1, 2) & Chr(10) & tabellen(6, akttabelle)
            'datum version
            'da  habe ich nix gefunden
            'Mitarbeit
            wApp.ActiveDocument.Tables(tab1).Cell(4, 2) = tabellen(7, akttabelle)
            'Bearbeitungszeitraum
            wApp.ActiveDocument.Tables(tab1).Cell(5, 2) = tabellen(8, akttabelle)
            'Meilensteine
            wApp.ActiveDocument.Tables(tab1).Cell(6, 2) = tabellen(9, akttabelle)
            'Ziele
            wApp.ActiveDocument.Tables(tab1).Cell(7, 2) = tabellen(4, akttabelle)
            'Lösungsansätze
            wApp.ActiveDocument.Tables(tab1).Cell(8, 2) = tabellen(10, akttabelle)
            
            If tabellen(1, temp) = "" Then
                tabellen(1, temp) = "x"
                'tabelle zwischenspeichern
                '.Tables(1).Range.copy
                tabspeicher(temp + 1) = 1
                tabspeicher(0) = tabspeicher(0) + 1
                doc.Tables(tab1).Range.copy
                neu.Activate
                wApp.Selection.Paste
                doc.Tables(1).Rows.Alignment = wdAlignRowCenter
                doc.Tables(1).Rows.WrapAroundText = False
                wApp.Selection.EndKey Unit:=wdStory
                wApp.Selection.TypeParagraph
                doc.Activate
            End If
            
            If akttabelle = 1 Then
                doc.Range(doc.Tables(tab1).Range.End, doc.Tables(tab1).Range.End).Select
                wApp.Selection.TypeParagraph

            End If
        End If
    Next akttabelle
    
    wApp.Documents(doc).Close SaveChanges:=True
Next user

wApp.Documents(neu).Close SaveChanges:=False
wApp.Quit
Set wApp = Nothing

End Sub