Option Explicit
Function ZellenFärben()
Dim rng As Range, AV, R&, C&, SerienNummer, SachNummer, Found()
Dim Path$, S1$, S2$
Path = ThisWorkbook.Path & "\Test.txt"
Set rng = ActiveSheet.UsedRange
If rng.Columns.Count < 4 Then Exit Function
With rng
.Interior.ColorIndex = xlNone
AV = .Value
End With
For R = 1 To UBound(AV)
S1 = AV(R, 2)
S2 = AV(R, 4)
If Not S1 = "" And Not S2 = "" Then
Select Case FindSN(S1, S2, Path)
Case 2
rng(R, 4).Interior.ColorIndex = 3
Case 3
rng(R, 4).Interior.ColorIndex = 4
End Select
End If
Next
End Function
Private Function FindSN(SachNummer, SerienNummer, Path$) As Integer
Dim List$(), FileName$, I&, TS$
If Not OpenTxt(List, Path) Then Exit Function
For I = 0 To UBound(List)
TS = List(I)
If InStr(1, TS, SachNummer) Then
FindSN = 1
If InStr(1, TS, SerienNummer) Then
FindSN = 2
If InStr(1, TS, "PASS") Then
FindSN = 3
Exit For
End If
End If
End If
Next
End Function
Private Function OpenTxt(FileData$(), ByVal FileName$) As Boolean
On Error GoTo BadData
Dim FileNum%, Fields$, I&
FileNum = FreeFile
ReDim FileData(0 To 0)
Open FileName For Input As FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, Fields
ReDim Preserve FileData(0 To I)
FileData(I) = Fields
I = I + 1
Loop
Close
FileName = 0
Fields = 0
I = 0
OpenTxt = True
Exit Function
BadData:
End Function