Daten 1 in Daten 2

[michel34497]

Halo Stefan!
Einfach SUPER! Tausen Dank dafür

Doch fehlen ja noch die 9 er (alleNeune) und Kranz was ja auch mit übertragen werden soll.
Wie ich ja schon einmal sagte wird hier anders eingetragen wie bei den Pumpen und Strafen.
Wenn ich im Blatt Spiele bei einen Spieler bei Kranz oder 9 er (AlleNeune) einen Wert eintrage, soll der Code dann bei allen anderen Spielern im Startblatt was eintragen auser bei dem der es geworfen hat. Es bezahlen alle auser der dies geworfen hat.
Ich hoffe es ist einigermasen verständlich

[WergibtmirRat]

Hallo Michael
Hab mal dein Tabellchen 'Michael_forum1' gezogen.
Mit dem Userform2 >Test< hab ich so meine kleinen Probleme
Combobox1 liest du per "ComboBox1.RowSource = ("A1:A117")" ein
Was ist hier der Zweck
Wäre nicht ein direkter Bezug auf eine Liste z.b. (Personen) unter RowSource [=Personen] sinnig?
Ich sehe ja auch, daß das UF "Test" heisst, ist es so wie der Titel sagt nur ein Test-UF ?

[Steffl]

Hallo Michael,

ja es war verständlich. Hier mal der Code

Code:

Sub prcUebernahme()
   Dim lngLetzteZeile As Long, lngC As Long
   Dim rngName As Range, rngGefuellt As Range
   Dim strZelle As String
  
  
   With Worksheets("Spiele")
      lngLetzteZeile = .Cells(69, 1).End(xlUp).Row 'von .Rows.Count auf 69 geändert :-(
      Set rngGefuellt = Worksheets("Startblatt").Range("F5:T22").Find(What:="*", lookat:=xlWhole, LookIn:=xlValues, _
      searchorder:=xlByColumns, SearchDirection:=xlPrevious)
      For lngC = 9 To lngLetzteZeile
         Set rngName = Worksheets("Startblatt").Columns(2).Find(.Cells(lngC, 1), lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
         If Not rngName Is Nothing Then
            If Not rngGefuellt Is Nothing Then
               If rngGefuellt.Column = 20 Then MsgBox "Alle Spalten sind gefüllt!", vbInformation: Exit For
               Worksheets("Startblatt").Cells(rngName.Row, rngGefuellt.Column + 1).Value = .Cells(lngC, 13).Value
            Else
               Worksheets("Startblatt").Cells(rngName.Row, 6).Value = .Cells(lngC, 13).Value
            End If
            strZelle = Mid(Worksheets("Startblatt").Cells(rngName.Row, 21).FormulaLocal, 13, _
            InStr(3, Worksheets("Startblatt").Cells(rngName.Row, 21).FormulaLocal, ">") - 13)
            Worksheets("Daten").Range(strZelle).Value = Worksheets("Daten").Range(strZelle).Value + .Cells(lngC, 12).Value
            Worksheets("Daten").Range(strZelle).Offset(, 1).Value = Worksheets("Daten").Range(strZelle).Offset(, 1).Value + .Cells(lngC, 9).Value
            If .Cells(lngC, 10) <> 0 Then
               .Cells(lngC, 10).Copy
               Worksheets("Daten").Range("D2:D20").PasteSpecial operation:=xlAdd
               Worksheets("Daten").Range(strZelle).Offset(, 3) = Worksheets("Daten").Range(strZelle).Offset(, 3).Value - .Cells(lngC, 10).Value
               Application.CutCopyMode = False
            End If
            If .Cells(lngC, 11) <> 0 Then
               .Cells(lngC, 11).Copy
               Worksheets("Daten").Range("C2:C20").PasteSpecial operation:=xlAdd
               Worksheets("Daten").Range(strZelle).Offset(, 2) = Worksheets("Daten").Range(strZelle).Offset(, 2).Value - .Cells(lngC, 11).Value
               Application.CutCopyMode = False
            End If
         End If
      Next lngC
   End With
   Set rngName = Nothing
   Set rngGefuellt = Nothing
End Sub

Du mußt hier aber noch die Formel im Tabellenblatt Startblatt ändern und zwar für die Spalte Y und AA. Formel neu für Zelle Y5

Code:

=WENN(UND(Daten!C2>0;B5<>"");Daten!C2;"")

und für die Zelle AA5

Code:

=WENN(UND(Daten!D2>0;B5<>"");Daten!D2/2;"")

Sonst werden in diesen Zellen, wenn in Spalte B keiner eingetragen ist, ein Formelergebnis eingetragen.

[michel34497]

Hallo Frank!

Wie du schon richtig erkannt hast ist dies wirklich nur eine Test UF.
Hab diese nicht weiter verfolgt. Vieleicht später mal.

[michel34497]

Hallo Stefan!

Was soll ich noch sagen!

Doch leider habe ich einen FEHLER bei der Formolierung gemacht!

Ich hab geschrieben: Es bezahlen alle auser der dies geworfen hat.
Es muss aber heißen: Es bezahlen alle anwesenden Spieler auser der dies geworfen hat.
Mein Fehler Sorry!
Nun trägt der Code bei allen Spielern was ein, wer aber nicht anwesend ist brauch die 9 er und Kranz nicht bezahlen.
Kann man das ändern?
Dann ist noch beim eintragen vom Kranz ein fehler. Ich habe im Startblatt bei den Drehfeld die Schrittweite 3 eingeben und dann in der Formel /2, dann kommt auch der Betrag von 1,5 heraus. Der Code schreibt aber nur eine 1, müsste aber eine 3 schreiben damit ich auf den Betrag von 1,5 komme. Habe im Code nachgeschaut, ob ich das selber ändern kann finde aber keinen richtigen ansatz.

[Steffl]

Hallo Michael,

ändere die Formel für die Zelle Y5 so ab

Code:

=WENN(UND(Daten!C2>0;C5=1);Daten!C2;"")

und für die Zelle AA5

Code:

=WENN(UND(Daten!D2>0;C5=1);Daten!D2/2;"")

Bezüglich dem Kranz: Muss ich mal schauen. Die Berechnung stimmt eh nicht, denn was ist, wenn zwei Teilnehmer jeweils einen 9er oder einen Kranz haben? Wie sieht es da aus?

[michel34497]

Hallo Stefan!
Die Formel für die Zellen Y5 und AA5 habe ich geändert.
Nach den ersten Tests sieht es gut aus. Habe auch getestet wenn mehere einen 9er oder Kranz haben, bis jetzt funktioniert es!
Teste aber noch genauer.
Ist halb jetzt das mit dem Betrag vom Kranz noch.

[Steffl]

Hallo Michael,

habe trotz das der Teil mit den 9er funktioniert es umgeschrieben und eine weitere Sub dazu erstellt. Teste mal (das mit den Kränzen dürfte jetzt auch passen)

Code:

Sub prcUebernahme()
   Dim lngLetzteZeile As Long, lngC As Long, lng9er As Long, lngKranz As Long
   Dim rngName As Range, rngGefuellt As Range
   Dim strZelle As String, str9er As String, strKranz As String
  
  
   With Worksheets("Spiele")
      lngLetzteZeile = .Cells(69, 1).End(xlUp).Row 'von .Rows.Count auf 69 geändert :-(
      Set rngGefuellt = Worksheets("Startblatt").Range("F5:T22").Find(What:="*", lookat:=xlWhole, LookIn:=xlValues, _
      searchorder:=xlByColumns, SearchDirection:=xlPrevious)
      For lngC = 9 To lngLetzteZeile
         Set rngName = Worksheets("Startblatt").Columns(2).Find(.Cells(lngC, 1), lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
         If Not rngName Is Nothing Then
            If Not rngGefuellt Is Nothing Then
               If rngGefuellt.Column = 20 Then MsgBox "Alle Spalten sind gefüllt!", vbInformation: Exit For
               Worksheets("Startblatt").Cells(rngName.Row, rngGefuellt.Column + 1).Value = .Cells(lngC, 13).Value
            Else
               Worksheets("Startblatt").Cells(rngName.Row, 6).Value = .Cells(lngC, 13).Value
            End If
            strZelle = Mid(Worksheets("Startblatt").Cells(rngName.Row, 21).FormulaLocal, 13, _
            InStr(3, Worksheets("Startblatt").Cells(rngName.Row, 21).FormulaLocal, ">") - 13)
            Worksheets("Daten").Range(strZelle).Value = Worksheets("Daten").Range(strZelle).Value + .Cells(lngC, 12).Value
            Worksheets("Daten").Range(strZelle).Offset(, 1).Value = Worksheets("Daten").Range(strZelle).Offset(, 1).Value + .Cells(lngC, 9).Value
            If .Cells(lngC, 10) <> 0 Then
               strKranz = strKranz & Range(strZelle).Offset(, 3).Address & "::" & .Cells(lngC, 10).Value * 3 & ","
               lngKranz = lngKranz + .Cells(lngC, 10).Value * 3
            End If
            If .Cells(lngC, 11) <> 0 Then
               str9er = str9er & Range(strZelle).Offset(, 2).Address & "::" & .Cells(lngC, 11).Value & ","
               lng9er = lng9er + .Cells(lngC, 11).Value
            End If
         End If
      Next lngC
   End With
   prcBerechnen "C2:C20", str9er, lng9er
   prcBerechnen "D2:D20", strKranz, lngKranz
   Set rngName = Nothing
   Set rngGefuellt = Nothing
End Sub

Sub prcBerechnen(strBereich As String, strTrenner As String, lngWerte As Long)
   Dim arWerte As Variant, arSpieler As Variant
   Dim lngC As Long
  
   If strTrenner <> "" Then
      Worksheets("Daten").Range(strBereich).Value = lngWerte
      arWerte = Split(strTrenner, ",")
      For lngC = 0 To UBound(arWerte) - 1
         arSpieler = Split(arWerte(lngC), "::")
         Worksheets("Daten").Range(arSpieler(0)).Value = Worksheets("Daten").Range(arSpieler(0)).Value - arSpieler(1)
      Next lngC
   End If
End Sub

[michel34497]

Hallo Stefan!

Hallo Michael,

habe trotz das der Teil mit den 9er funktioniert es umgeschrieben und eine weitere Sub dazu erstellt. Teste mal (das mit den Kränzen dürfte jetzt auch passen)

Ich habe es getestet und leider funktioniert es nicht richtig
Beim ersten durchlauf trägt er alles richtig ein startet man den Code nochmals werden bei den 9er der wert nicht weiter addiert genauso bei Kranz.

[Steffl]

Hallo Michael,

ersetze diese Codezeile

Code:

Worksheets("Daten").Range(strBereich).Value = lngWerte

durch diese

Code:

Worksheets("Daten").Range(strBereich).Value = Worksheets("Daten").Range(strBereich).Value + lngWerte

Ist aber ungetestet