Option Explicit

Sub subzerox()

Dim lngLastRow&
Dim lngCounter&
Dim lngWriteLine&
Dim lngColumn&
Dim wsData As Worksheet
Dim wsComp As Worksheet

'Konstanten für Spalte und Suchbegriff
Const cstrCOL As String = "B"
Const cstrFIND As String = "4"

'Tabellen zur Bearbeitung festlegen
Set wsData = Worksheets("Tabelle1")
Set wsComp = Worksheets("Tabelle2")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Feststellen der letzten genutzten Zeile in Spalte B ohne Prüfung
'letzte Zelle auf Inhalt
lngLastRow = wsData.Cells(Rows.Count, cstrCOL).End(xlUp).Row
'Breite des zu kopierenden Bereiches feststellen
lngColumn = wsData.Range("A2").End(xlUp).Row
'Erste Zeile zum Schreiben in Zieltabelle
lngWriteLine = 1

'Durchlaufen des Bereiches
For lngCounter = 2 To lngLastRow
   'Prüfen, ob sich das gesuchte Zeichen in Zelle befindet
   If InStr(1, wsData.Cells(lngCounter, cstrCOL).Value, cstrFIND) > 0 Then
      wsComp.Range(wsComp.Cells(lngWriteLine, 1), wsComp.Cells(lngWriteLine, lngColumn)).Value = _
            wsData.Range(wsData.Cells(lngCounter, 1), wsData.Cells(lngCounter, lngColumn)).Value
      'Zähler für Schreibzeile
      lngWriteLine = lngWriteLine + 1
   End If
Next lngCounter

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

Set wsComp = Nothing
Set wsData = Nothing

End Sub