Tag Gemeinde,
ich komme mit einem Problem auch nach langem Suchen nicht weiter:
Ich möchte in einem Word-Dokument Worte automatisch ersetzen lassen. Die zu findenden Worte sollen sich als Liste in einer Excel-Tabelle Spalte A befinden. In der Excel-Tabelle, Spalte B soll sich jeweils das Ersatzwort befinden.
Beispiel: Liste:
A B
Haus Gebäude
Auto Fahrzeug…
…usw.
Im Ergebnis soll das so aussehen (A durch B ersetzt):
Ursprünglicher Text:
Das Auto fährt in ein Haus.
Ersetzter Text:
Das Fahrzeug fährt in ein Gebäude.
Ich habe folgendes Makro gefunden, was schon in die Richtung geht, jedoch Findwörter nur markiert:
Const xlUp = -4162
Sub ersetze()
Dim obExcel As Object
Dim obMap As Object
Dim lastrow As Long, i as long
On Error GoTo errHandler
Set obExcel = CreateObject(„Excel.application“)
'oExcel.Visible = True
Set obMap = obExcel.Workbooks.Open(„c:\datenxls.xls“) 'anpassen
With obMap.Worksheets(1)
'letzte befüllte zelle in Spalte A ermitteln
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To lastrow
With Selection
.Find.Replacement.Highlight = True
.Find.Text = obMap.Worksheets(1).Cells(i, 1).Value
.Find.Replacement.Text = obMap.Worksheets(1).Cells(i, 1).Value
.Find.Forward = True
.Find.Wrap = wdFindContinue
.Find.Format = True
.Find.Execute Replace:=wdReplaceAll
End With
Next
obExcel.Quit
Set obMap = Nothing
Set obExcel = Nothing
Exit Sub
errHandler:
MsgBox Err.Description
obExcel.Quit
Set obMap = Nothing
Set obExcel = Nothing
End Sub
Leider habe ich überhaupt keinen Plan von dieser Art von Programmierung, kann jemand helfen?
ThX
Ich möchte in einem Word-Dokument Worte automatisch ersetzen
lassen. Die zu findenden Worte sollen sich als Liste in einer
Excel-Tabelle Spalte A befinden. In der Excel-Tabelle, Spalte
B soll sich jeweils das Ersatzwort befinden.
Hallo Där,
probiere es ungetestet mal so:
Option Explicit
'
Const xlUp = -4162
'
Sub ersetze()
Dim obExcel As Object, obMap As Object, i As Long
On Error GoTo errHandler
Set obExcel = CreateObject("Excel.application")
Set obMap = obExcel.Workbooks.Open("c:\datenxls.xls") 'anpassen
With Selection
For i = 1 To obMap.Worksheets(1).Cells(.Rows.Count, 1).End(xlUp).Row
'.Find.Replacement.Highlight = True
.Find.Text = obMap.Worksheets(1).Cells(i, 1).Value
.Find.Replacement.Text = obMap.Worksheets(1).Cells(i, 2).Value
.Find.Forward = True
.Find.Wrap = wdFindContinue
.Find.Format = True
.Find.Execute Replace:=wdReplaceAll
Next
End With
errHandler:
If Err.Number 0 Then MsgBox Err.Number & Chr(10) & Err.Description
obExcel.Quit
Set obMap = Nothing
Set obExcel = Nothing
End Sub
Gruß
Reinhard
Hallo Reinhard,
danke für´s reinschauen. Mit dem ungeprüften Code tut sich gar nichts…
Gibts noch weitere Ideen von den Experten?
ThX
Hallo Dar,
danke für´s reinschauen. Mit dem ungeprüften Code tut sich gar
nichts…
sicher datt? Keine Fehlermeldungen? Bei mir kamen welche…
Gibts noch weitere Ideen von den Experten?
Diesmal getestet (Office 2000):
Option Explicit
'
Const xlUp = -4162
'
Sub ersetze()
Dim obExcel As Object, obMap As Object, i As Long
On Error GoTo errHandler
Set obExcel = CreateObject("Excel.application")
Set obMap = obExcel.Workbooks.Open("c:\test\kwdar.xls") 'anpassen
obExcel.Visible = True
For i = 1 To obMap.Worksheets(1).Cells(obMap.Worksheets(1).Rows.Count, 1).End(xlUp).Row
With Selection
.Find.Text = obMap.Worksheets(1).Cells(i, 1).Value
.Find.Replacement.Text = obMap.Worksheets(1).Cells(i, 2).Value
.Find.Forward = True
.Find.Wrap = wdFindContinue
.Find.Format = True
.Find.Execute Replace:=wdReplaceAll
End With
Next i
errHandler:
If Err.Number 0 Then MsgBox Err.Number & Chr(10) & Err.Description
obExcel.Quit
Set obMap = Nothing
Set obExcel = Nothing
End Sub
Gruß
Reinhard