Clever-Excel-Forum

Seiten: 1 2 3 4

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

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 ?

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.

Hallo Frank!

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

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.

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?

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.

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

Hallo Stefan!

(18.05.2014, 18:41)Steffl schrieb: [ -> ]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.

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

Seiten: 1 2 3 4

michel34497

WergibtmirRat

Steffl

michel34497

michel34497

Steffl

michel34497

Steffl

michel34497

Steffl