'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr


'kopieren nach _Tabelle_ "Deckungsbeitrag"
'wenn Änderung im Worksheet,dann rufe finde auf

'Funktion finde wird bei Änderung/Neueingabe in Zellen in Zeile 1 gestartet

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error GoTo abbruch
    'rufe die Subroutine finde auf und zwar
    'nur bei Wertänderung in Zeile 1
    'und nur, wenn die geänderte(n) Zelle(n) nicht leer ist (sind)
    If Target.Row = 1 And Target <> "" Then
      Call finde(Target)
    End If
abbruch:
End Sub







'das makro gehört in Module z.B. in Modul1
'dies _nicht_ in Tabelle Deckungsbeitrag hineinkopieren!
'Zelle aktivieren und Makro aufrufen geschieht durch
'Worksheet_change (s.o.)

'finde vergleicht den Suchwert mit Werten aus Tabelle(wsn) Spalte 3
'und bei Gleichheit kopiert die Funktion den Wert aus Spalte 6 und Spalte 25
'in das aktive Worksheet "Deckungsbeitrag" und zwar maximal 20 Treffer
'abgelegt in Zeile 2 bis Zeile 21

Sub finde(zelle As Range)
On Error Resume Next
Dim r As Range
Dim wsn As String
Dim s1, s2, s3 As Long
'mit folgender Eingabe werden
'alte Daten gelöscht!
loesch_chr = "del@"
wsn = "Personal-Leistungserfassung"
s1 = 3: s2 = 6: s3 = 25 'c=3,f=6,y=25
zaehler = 0 'Daten von Zeile 2
max_zaehler = 20 'bis Zeile 21
suchwert = zelle
If suchwert = loesch_chr Then
   'Eingabe von del@ in Zeile 1
   'löscht die ALTEN Daten darunter (2Spalten) bis
   'zur Zeile 21
   Call loesche_alte_daten(zelle, max_zaehler)
   Exit Sub
End If
For Each r In Worksheets(wsn).UsedRange.Rows
  'in Spalte C wird der suchwert gesucht
  If Worksheets(wsn).Cells(r.Row, s1) = suchwert Then
     zaehler = zaehler + 1
     If zaehler > max_zaehler Then GoTo max_gefunden
     'kopiere den Wert aus Spalte F & Y
     zelle.Offset(zaehler, 0) = Worksheets(wsn).Cells(r.Row, s2)
     zelle.Offset(zaehler, 1) = Worksheets(wsn).Cells(r.Row, s3)
  End If
  'leere restliche Zeilen bis max_zaehler
Next r
  'nur mit Leerzellen auffüllen wo notwendig und sinnvoll
  If zaehler > 0 And zaehler < max_zaehler Then
     For i = zaehler + 1 To max_zaehler
     zelle.Offset(i, 0) = ""
     zelle.Offset(i, 1) = ""
     Next i
  End If
max_gefunden:
End Sub


'hiermit werden alte Daten gelöscht - wird "del@" im Worksheet
'Deckungsbeitrag in eine Zelle in Zeile 1 eingetragen, dann werden
'20 Zeilen darunter 2 Spalten breit gelöscht


Sub loesche_alte_daten(z As Range, mz As Variant)
   For i = z.Row To mz
     z.Offset(i, 0) = ""
     z.Offset(i, 1) = ""
   Next i
   z = ""
End Sub