Lieber Experte,
habe seit längerem ein Makro laufen, läuft einwandfrei und bräuchte noch eine Erweiterung dazu.
Leider ist mir der Ersteller des Makros nicht mehr bekannt.
Es handelt sich um ein Suchen Ersetzen Makro das Deutsche Wörter nach Englische übersetzt.
Die Übersetzungspaare sind im Tabellenblatt „Translation“
Spalte A Deutsch, Spalte B Englisch.
In der gleichen Arbeitsmappe befindet sich das Tabellenblatt „Gesamtstückliste“ in der die Wörter gesucht und ersetzt werden.
Das gesamte Tabellenblatt wird durchsucht und einzelne Zellen ersetzt.
Da ich oft mehr als 4000 Zeilen habe wäre es super, wenn die ersetzten Zellen farbig dargestellt würden.
Vielen Dank für die Mühe - OS2
Hier das Makro:
Sub mehrfachSuchenUndErsetzen()
'sucht im aktiven Tabellenblatt jeweils die Eintraege aus
'suchArray und ersetzt mit ersetzArray
Application.ScreenUpdating = False
Dim wksTrans As Worksheet, wksAkt As Worksheet
Dim suchArray()
Dim ersetzArray()
Dim k As Long, Zeile As Long
Set wksAkt = ActiveSheet
Set wksTrans = Worksheets(„Translation“)
Const Zeile1 = 2 'Zeile mit 1. Übersetzungsdaten im Blatt „Translation“
If wksAkt.Name = wksTrans.Name Then
MsgBox „Im Blatt „„Translation““ darf das Übersetzungsmakro nicht eingesetzt werden!“, _
vbInformation, „Übersetzen“
GoTo Beenden
End If
If MsgBox(„Daten im Tabellenblatt übersetzen“, vbQuestion + vbYesNo, _
„Übersetzen“) = vbNo Then GoTo Beenden
'Übersetzungswerte in Datenarrays einlesen
With wksTrans
'letzte Zeile mit Daten
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'nach Spalte A aufsteigend sortieren ab Zeile 2 (Zeile1 hat Spaltentitel)
With .Range(.Rows(Zeile1), .Rows(Zeile))
.Sort key1:=.Range(„A1“), order1:=xlAscending, Header:=xlNo
End With
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim suchArray(Zeile1 To Zeile)
ReDim ersetzArray(Zeile1 To Zeile)
For Zeile = Zeile1 To Zeile
suchArray(Zeile) = .Cells(Zeile, 1)
ersetzArray(Zeile) = .Cells(Zeile, 2)
Next Zeile
End With
'Daten in absteigender Reihenfolge ersetzen.
'Ist wichtig, wenn „Lookat“ nicht xlWhole sondern xlPart ist-austauschen unten
For k = UBound(suchArray) To LBound(suchArray) Step -1
wksAkt.UsedRange.Replace what:=suchArray(k), Replacement:=ersetzArray(k), _
Lookat:=xlWhole, MatchCase:=False
Next k
Beenden:
'Variablen aufräumen
Set wksTrans = Nothing: Set wksAkt = Nothing
Erase suchArray(), ersetzArray()
Application.ScreenUpdating = True
End Sub
