hier die angepassten Codes.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub SuchenUndErsetzen()
Dim strFile As String, strTmp As String, strFind As String, strInput
Dim vntRet As Variant
Dim rng As Range
Const sngReplaceFrom As Single = 15 'Position des Suchbegriffes
Const sngReplaceLen As Single = 3 'Länge des Suchbegriffes
Dim FF1 As Integer, FF2 As Integer
strFile = Application.GetOpenFilename("XYZ Dateien (*.xyz),*.xyz,XXX Dateien (*.xxx), *.xxx,Alle Dateien (*.*),*.*")
If strFile = CStr(False) Then Exit Sub
strTmp = Environ("TMP") & "\xyz.tmp"
With ThisWorkbook.Sheets("Tabelle1")
Set rng = .Range("B2:B22") 'Bereich mit den alten Bezeichnungen, die Neuen stehen in der Spalte daneben
rng.Offset(0, 2).ClearContents
FF1 = FreeFile
Open strFile For Input As #FF1
FF2 = FreeFile
Open strTmp For Output As #FF2
Do While Not EOF(FF1)
Line Input #FF1, strInput
strFind = Mid(strInput, sngReplaceFrom, sngReplaceLen)
vntRet = Application.Match(Clng(strFind), rng, 0)
If IsNumeric(vntRet) Then
strInput = Left(strInput, sngReplaceFrom - 1) & rng.Cells(vntRet, 1).Offset(0, 1).Text & Mid(strInput, sngReplaceFrom + sngReplaceLen)
rng.Cells(vntRet, 1).Offset(0, 2) = rng.Cells(vntRet, 1).Offset(0, 2) + 1
End If
Print #FF2, strInput
Loop
Close #FF1
Close #FF2
If Dir(strFile & ".alt", vbNormal) <> "" Then Kill strFile & ".alt"
Name strFile As strFile & ".alt" 'Backup
Name strTmp As strFile
.Range("B25") = strFile
MsgBox "Es wuden " & Application.Sum(rng.Offset(0, 2)) & " Werte geändert!", vbInformation
End With
Set rng = Nothing
End Sub
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub SuchenUndErsetzen2()
Dim strFile As String, strTmp As String, strFind As String, strInput
Dim vntRet As Variant
Dim rng1 As Range, rng2 As Range
Dim FF1 As Integer, FF2 As Integer
Const sngReplaceFrom1 As Single = 10 'Position des 1. Suchbegriffes
Const sngReplaceLen1 As Single = 1 'Länge des 1. Suchbegriffes
Const sngReplaceFrom2 As Single = 30 'Position des 2. Suchbegriffes
Const sngReplaceLen2 As Single = 3 'Länge des 2. Suchbegriffes
strFile = Application.GetOpenFilename("XYZ Dateien (*.xyz),*.xyz,XXX Dateien (*.xxx), *.xxx,Alle Dateien (*.*),*.*")
If strFile = CStr(False) Then Exit Sub
strTmp = Environ("TMP") & "\xyz.tmp"
With ThisWorkbook.Sheets("Tabelle2")
Set rng1 = .Range("B2:B10") '1. Bereich mit den alten Bezeichnungen, die Neuen stehen in der Spalte daneben
Set rng2 = .Range("F2:F22") '2. Bereich mit den alten Bezeichnungen, die Neuen stehen in der Spalte daneben
rng1.Offset(0, 2).ClearContents
rng2.Offset(0, 2).ClearContents
FF1 = FreeFile
Open strFile For Input As #FF1
FF2 = FreeFile
Open strTmp For Output As #FF2
Do While Not EOF(FF1)
Line Input #FF1, strInput
strFind = Mid(strInput, sngReplaceFrom1, sngReplaceLen1)
vntRet = Application.Match(Clng(strFind), rng1, 0)
If IsNumeric(vntRet) Then
strInput = Left(strInput, sngReplaceFrom1 - 1) & rng1.Cells(vntRet, 1).Offset(0, 1).Text & Mid(strInput, sngReplaceFrom1 + sngReplaceLen1)
rng1.Cells(vntRet, 1).Offset(0, 2) = rng1.Cells(vntRet, 1).Offset(0, 2) + 1
End If
strFind = Mid(strInput, sngReplaceFrom2, sngReplaceLen2)
vntRet = Application.Match(Clng(strFind), rng2, 0)
If IsNumeric(vntRet) Then
strInput = Left(strInput, sngReplaceFrom2 - 1) & rng2.Cells(vntRet, 1).Offset(0, 1).Text & Mid(strInput, sngReplaceFrom2 + sngReplaceLen2)
rng2.Cells(vntRet, 1).Offset(0, 2) = rng2.Cells(vntRet, 1).Offset(0, 2) + 1
End If
Print #FF2, strInput
Loop
Close #FF1
Close #FF2
If Dir(strFile & ".alt", vbNormal) <> "" Then Kill strFile & ".alt"
Name strFile As strFile & ".alt" 'Backup
Name strTmp As strFile
.Range("B25") = strFile
MsgBox "Es wuden " & Application.Sum(rng1.Offset(0, 2)) & " bei Wert 1" & _
vbLf & "und " & Application.Sum(rng2.Offset(0, 2)) & _
" bei Wert 2 geändert!", vbInformation
End With
Set rng1 = Nothing
Set rng2 = Nothing
End Sub