Hallo

- Rechtsclick auf den Tabellenblattreiter von Vorlage

- Code anzeigen

- Code rechts reinkopieren

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KdNr As Integer, ZielRNG As Range, SuchRNG As Range
    Dim Tb1 As Worksheet, Tb2 As Worksheet
    Dim LR1 As Integer, LR2 As Integer, Z1 As Integer
    
    Const APPNAME = "Worksheet_Change"
    
    Set Tb1 = Sheets("Vorlage")
    Set Tb2 = Sheets("Artikelübersicht")
    Z1 = 9 'erste Zielzeile
    
    Set ZielRNG = Tb1.Cells(Z1, 1)
    
    If Not Intersect(Range("B1"), Target) Is Nothing Then
        On Error GoTo Fehler
    
        LR1 = Tb1.Cells(Tb1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
        LR2 = Tb2.Cells(Tb2.Rows.Count, 1).End(xlUp).Row
        
        'Reset
        If LR1 > Z1 Then
            Application.EnableEvents = False
            ZielRNG.Resize(LR1 - Z1 + 1, 2).ClearContents
            Application.EnableEvents = True
        End If
        
        If Tb2.AutoFilterMode Then Tb2.AutoFilterMode = False ' Autofilter ausschalten
        
        Set SuchRNG = Tb2.Range("A1:A" & LR2)
        If WorksheetFunction.CountIf(SuchRNG, Target) > 0 Then
            
            SuchRNG.AutoFilter
            SuchRNG.AutoFilter Field:=1, Criteria1:=Target
            
            'kopieren
            SuchRNG.Offset(1, 2).Resize(LR2, 2).Copy ZielRNG
            Application.EnableEvents = True
            
            Tb2.AutoFilterMode = False
        Else
            MsgBox "Keine Daten für Kunde: " & Target
        End If
    End If
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub