Option Explicit
Sub DatenInSammelDatei()
Dim wbSammel As Workbook, strSammelPfad As String, strSammelDatei As String
Dim strBereich As String, strS As String
Dim ShT As Worksheet, x As Long, c As Range
strSammelDatei = "Ziel.xlsx"
strSammelPfad = "\\G-PC\F\"
strBereich = "D1:AI50"
strS = "K"
Application.ScreenUpdating = False
On Error Resume Next
Set wbSammel = Workbooks(strSammelDatei)
If Err.Number Then _
Set wbSammel = Workbooks.Open(strSammelPfad & strSammelDatei)
On Error GoTo 0
ThisWorkbook.Activate
For x = 1 To 12
Set ShT = wbSammel.Sheets(MonthName(x))
Sheets(MonthName(x)).Range(strBereich).Copy ShT.Range(strBereich)
For Each c In ShT.Range(strBereich).Cells
If InStr(c.Value, strS) Then
c.ClearContents
c.Interior.ColorIndex = 5
End If
Next c
Next x
wbSammel.Close savechanges:=True
Set wbSammel = Nothing
Set ShT = Nothing
Application.ScreenUpdating = True
End Sub