AW: VBA in xlsm
19.08.2020 19:57:54
Peter
Hallo Matthias,
besten Dank für Deine Hilfe. Ich habe jetzt eine Lösung gefunden, die einwandfrei funktioniert.
Es wird aus dem ersten Worddokument der vorhandene Pfad und Name ausgelesen, dann wird geprüft, ob dieser mit den Daten aus dem geöffneten Programm identisch ist. Identisch = exit Sub. Nicht identisch werden alle Dokumente ersetzt mit neuem Namen.
Sub Prüfung_bzw_Änderung_der_Worddokumente() 'damit Spalte E nicht erforderlich
Dim wb As Workbook 'benötigt für Workbook
Dim wsWd As Worksheet 'benötigt für Worksheet Worddaten
Dim iRow As Long, iLastRow As Long 'benötigt für Durchlaufen der Worddokumente
Dim strWert As String 'benötigt für Auslesen Pfad Name erste Worddokument
Dim strWert2 As String 'benötigt für Durchlaufen der Worddokumente
Dim strPfad As String 'benötigt für Auslesen Pfad Name erste Worddokument und _
Durchlaufen der Worddokumente
Dim objWordApp As Object 'benötigt für öffnen Word
Dim objWDDoc As Object 'benötigt für öffnen Worddokument
Dim wdDoc As String 'benötigt für Auswahl Name des Worddokuments aus der _
Tabelle3
Dim varText As String 'benötigt für Auslesen von Code aus Worddokument
Dim SucheNach As String 'benötigt für den Suchbegriff aus dem Worddokuments
Dim ErsetzeDurch As String 'benötigt für den ErsetzeDurch = Wert der aktuellen _
Datei
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wsWd = wb.Worksheets("Worddaten")
With wsWd
strPfad = .Range("B46").Value
strWert = strPfad & .Cells(2, 3).Value 'strWert = der gültige Pfad und das _
Worddokument
'Debug.Print strWert
'Anfang - Worddokument Pfad übertragen
wdDoc = strWert 'strWert = der gültige Pfad und das Worddokument
Set objWordApp = GetObject(wdDoc) 'damit wird Worddokument nicht sichtbar geöffnet( _
nur scheinbar geöffnet)
'Anfang ersten Eintrag auswählen und auslesen
With objWordApp
varText = .Fields(1).Code 'Code aus dem 1. Feld aus geöffnetem Worddokument
varText = Mid(varText, InStr(1, varText, ":") - 1, InStr(1, varText, ".xlsm") + 6 - _
InStr(1, varText, ":")) 'Umwandlung nur Teil aus dem Code
End With
'Ende ersten Eintrag auswählen und auslesen
.Range("B44") = """" & varText & """" 'hinzufügen von Anführungszeichen vor und _
nach dem ausgelesenen Code
End With 'End With für wsTB3
objWordApp.Close SaveChanges:=True
Set objWDDoc = Nothing
'Ende - Worddokument Pfad übertragen
'Anfang alle Worddokumente ändern
With wsWd
SucheNach = .Range("B44").Value
'Debug.Print SucheNach
ErsetzeDurch = .Range("B42").Value
'Debug.Print ErsetzeDurch
'Prüfung - ob identisch
'nicht identisch mit Abbruch
If ErsetzeDurch = SucheNach Then
MsgBox "beide Werte gleich = Abbruch"
Application.ScreenUpdating = True
Exit Sub
'identisch Fortsetzung des Makro
ElseIf ErsetzeDurch SucheNach Then
MsgBox "beide Werte nicht gleich = Makro"
Set objWordApp = CreateObject("Word.Application")
'objWordApp.Visible = True
objWordApp.Visible = False
iLastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
strPfad = .Range("B46").Value
For iRow = 2 To iLastRow
If .Cells(iRow, 3).Value Empty Then 'nur die nicht leeren Zellen werden _
ausgelesen
strWert2 = strPfad & .Cells(iRow, 3).Value 'strWert = der gültige Pfad und _
das Worddokument
'Debug.Print strWert2
Set objWDDoc = objWordApp.Documents.Open(strWert2)
objWDDoc.ActiveWindow.View.ShowFieldCodes = True 'Word-VBA öffnen
'Anfang alles umwandeln
objWordApp.Selection.Find.ClearFormatting
objWordApp.Selection.Find.Replacement.ClearFormatting
objWordApp.Selection.Find.Execute FindText:=SucheNach, ReplaceWith:= _
ErsetzeDurch, Replace:=2 'Fehler
'Ende alles umwandeln
objWDDoc.ActiveWindow.View.ShowFieldCodes = False 'Word-VBA schliessen
End If
'Ende - ob identisch
Application.ScreenUpdating = True
objWDDoc.Close SaveChanges:=True
Next 'für For
End If
objWordApp.Quit
Set objWDDoc = Nothing
End With 'End With für TB3
'Ende alle Worddokumente ändern
End Sub
Es existieren jetzt kleine Änderungen bezüglich Bezug der Daten.
Gruss
Peter