Hallo Gemeinde,

ich habe eine kleine Tabelle wo ich Punkte für gewisse Kriterien verteilen kann. Hier kann einmal Kind1 oder Kind2 von Kind1 od.2 (Kind1 kann nur sich selbst bewerten sowie Kind2 nicht Kind1 bewerten kann und umgedreht), Mama und Papa bewertet werden. Hierzu habe ich zwei Dopdown Felder, wo im Feld 1 das zu bewertende Kind ausgewählt wird und danach im Feld 2 der Bewerter, mit einer Datenabgleichsliste verknüpft. Jetzt möchte ich gern, nach Abschluss der Bewertung, diese Daten in die jeweilige Registerkarte und die jeweilige Zelle kopieren. Ich habe es mit Simplen IF Befehlen hinbekommen suche aber jetzt eventuell eine schönere Lösung, da das Ausführen bzw. klicken des Buttons mir erstens zu lange Dauert und zweitens das Bild dann "flackert" (öffnet und schließt die jeweilige Registerkarte).

Vielleicht kann mir hier einer unter die Arme greifen und den folgenden Code optimieren. Ich habe hier schon öfter gute Erfahrungen mit euren Hilfen gemacht und bedanke mich schon mal sehr im Voraus.

Aktueller Code:

Private Sub Button1_Click()
If Range("B4") = "Kind1" And Range("B18") = "Kind1" Then
'Blattschutz deaktivieren
      Worksheets("Kind1").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind1").Range("D10").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind1").Protect "Password"
End If

If Range("B4") = "Kind1" And Range("B18") = "Mama" Then
'Blattschutz deaktivieren
      Worksheets("Kind1").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind1").Range("D11").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind1").Protect "Password"
End If

If Range("B4") = "Kind1" And Range("B18") = "Papa" Then
'Blattschutz deaktivieren
      Worksheets("Kind1").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind1").Range("D12").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind1").Protect "Password"
End If

If Range("B4") = "Kind2" And Range("B18") = "Kind2" Then
'Blattschutz deaktivieren
      Worksheets("Kind2").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind2").Range("D10").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind2").Protect "Password"
End If

If Range("B4") = "Kind2" And Range("B18") = "Mama" Then
'Blattschutz deaktivieren
      Worksheets("Kind2").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind2").Range("D11").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind2").Protect "Password"
End If

If Range("B4") = "Kind2" And Range("B18") = "Papa" Then
'Blattschutz deaktivieren
      Worksheets("Kind2").Unprotect "Password"
      With Worksheets("Kriterien")
      .Range("H16").Copy
      Worksheets("Kind2").Range("D12").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End With
'Blattschutz aktivieren
      Worksheets("Kind2").Protect "Password"
End If

End Sub

Beste Grüße

Chris