Frage an Erich G.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Dict_VomVorigen() Dim mDic As Object, mm As Long, arT, arN, arErg() As Double Dim zz As Long, cc As Long, strH As String Set mDic = CreateObject("Scripting.Dictionary") ' Teams / next mm = Cells(Rows.Count, 15).End(xlUp).Row - 1 arT = Cells(2, 15).Resize(mm, 2) ' O:P IDs Home+Away arN = Cells(2, 27).Resize(mm, 2) ' AA:AB next ges H+A ReDim arErg(1 To mm, 1 To 2) For zz = 1 To mm ' Zeilen For cc = 1 To 2 ' Home/Away strH = arT(zz, cc) ' Key = Team-ID If mDic.Exists(strH) Then arErg(zz, cc) = mDic(strH) mDic(strH) = arN(zz, cc) Else arErg(zz, cc) = 1000 mDic.Add strH, arN(zz, cc) End If Next cc Next zz Cells(2, 20).Resize(mm, 2) = arErg ' Spalten T:U End Sub

Hallo Erich,
perfekt, vielen Dank! Ja, deine Annahme war korrekt. Land, Liga, Saison spielen in diesem Fall keine Rolle. Durch die eindeutigen Team-IDs ist dies nicht nötig. Ziel ist es, für jede Mannschaft eine Teamstärke zu ermitteln, um so ein Prognosemodell für zukünfte Spiele zu entwickeln. Hierfür ist es nötig, viele vergangene Saisons zu berücksichtigen, damit sich einigermaßen korrekte Ratings ergeben. Auch Liga übergreifend. Also durch Europapokalspiele wird mit der Zeit die Bundesliga im Mittel stärker sein als z.B. die 1. Liga Dänemarks. Und durch DFB-Pokal werden die Teams aus der ersten Liga den Zweitligisten die Punkte klauen, so dass auch hier sich die Ligastärken mit der Zeit anpassen.
Ich kann im Moment noch nicht sagen, welche Faktoren in das Modell einfließen werden, um die beste Prognose zu erhalten, daher werde ich zukünftig immer wieder neue Dinge prüfen müssen. Und daher ist es halt wichtig, die Methode der VBA-Codes zu verstehen.
Alle weiteren Spalten in der Tabelle, die in der Formel ein Zählenwenn oder Summewenn enthalten, müssten ebenfalls mit VBA-Code gelöst werden, da Excel diese Formeln bei der Anzahl der Zeilen nicht schafft. Ich denke, dass die Spalten ab AC alle verschiedenen Berechnungsvarianten enthalten, so dass ich zukünftig die Codes gut eigenständig modifizieren könnte, um so alle denkbaren Rechnungen durchzuführen. Wenn ich also z.B. anstatt der letzten 10 Spiele die letzten 8 Spiele in Betracht ziehen möchte oder anstatt der geschossenen Tore die erzielten Punkte der letzten Spiele ermitteln möchte, denke ich, dass ich es schaffe, die Codes entsprechend abzuändern.
Von daher wäre es wirklich hervorragend, wenn du mir die Codes für die Spalten ab AC erstellen könntest, wenn die jeweilige Spalte eine solche rechenaufwendige "Wenn"-Formel enthält. Die Spalten wiederholen sich ja immer für Home und Away. Die jeweils 2. eigentlich identische Spalte könnte ich dann natürlich auch selbst machen.
Genau sind es folgende unterschiedliche Spalten, von denen ich sehr gern ein Muster hätte:
AC,AE,AG,AK,AO
Die Formel für "Toto" kannte ich noch gar nicht! Das ist ein sehr guter Tipp! Danke!
Ich hoffe, dass es nicht zu umständlich ist und würde mich wirklich sehr freuen, wenn du mir mit der Tabelle weiterhilfst!
Viele Grüße,
Andre

Option Explicit Sub Dict_Diverses() Dim mDic As Object, sDic As Object, aa As Long, arS, arT, arM, arErg() Dim zz As Long, cc As Long, strH As String, arW, mm As Integer Set mDic = CreateObject("Scripting.Dictionary") ' Teams / next Set sDic = CreateObject("Scripting.Dictionary") ' Sais+Team / Anz Sheets("TestTab").Select ' testhalber aa = Cells(Rows.Count, 15).End(xlUp).Row - 1 arS = Cells(2, 4).Resize(aa, 1) ' D Saison arT = Cells(2, 8).Resize(aa, 2) ' H:I Tore Home+Away arM = Cells(2, 15).Resize(aa, 2) ' O:P IDs Home+Away ReDim arErg(1 To aa, 1 To 26) For zz = 1 To aa ' Zeilen ' ---------------------------------------------- Sp. Q Toto If arT(zz, 1) > arT(zz, 2) Then arErg(zz, 1) = 1 ElseIf arT(zz, 1) = 10 Then _ arErg(zz, 24 + cc) = arW(10, 2) ' Torsumme arW(10, 2) = arW(10, 2) - arW(mm, 2) + arT(zz, cc) ' Torsumme arW(mm, 2) = arT(zz, cc) ' Tore mDic(strH) = arW Else ReDim arW(0 To 12, 1 To 2) arW(0, 1) = arErg(zz, 3 + cc) ' 1. Wert aus T:U arW(11, 1) = arErg(zz, 10 + cc) arW(12, 1) = 1 arW(0, 2) = arT(zz, cc) ' Tore arW(10, 2) = arT(zz, cc) ' Torsumme mDic.Add strH, arW End If ' ----------- Indizes 17 und 18 ---------------- Sp. AG:AH RatVor10 ' ----------- Indizes 19 und 20 ---------------- Sp. AI:AJ Verä Rat If arErg(zz, 12 + cc) >= 10 Then arErg(zz, 16 + cc) = arW(10, 1) arErg(zz, 18 + cc) = arErg(zz, 3 + cc) - arW(10, 1) End If ' ----------- Indizes 15 und 16 ---------------- Sp. AE:AF AnzSais H+A ' ----------- Indizes 21 und 22 ---------------- Sp. AK:AL Rat SaisBeg ' ----------- Indizes 23 und 24 ---------------- Sp. AM:AN Änd SaisBeg strH = arS(zz, 1) & arM(zz, cc) ' Key = Saison&Team If sDic.Exists(strH) Then arW = sDic(strH) arW(1) = arW(1) + 1 sDic(strH) = arW(1) arErg(zz, 14 + cc) = arW(1) arErg(zz, 20 + cc) = arW(2) arErg(zz, 22 + cc) = arErg(zz, 3 + cc) - arW(2) sDic(strH) = arW Else arErg(zz, 14 + cc) = 0 ReDim arW(1 To 2) arW(1) = 1 arW(2) = arErg(zz, 3 + cc) arErg(zz, 20 + cc) = arW(2) arErg(zz, 22 + cc) = arErg(zz, 3 + cc) - arW(2) sDic.Add strH, arW End If Next cc Next zz Cells(2, 17).Resize(aa, UBound(arErg, 2)) = arErg ' Spalten Q:AP End Sub

Sub start() Dim Calc As XlCalculation With Application Calc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False Dict_Diverses .EnableEvents = True .ScreenUpdating = True .Calculation = Calc End With End Sub

' ----------- Indizes 25 und 26 ---------------- Sp. AO:AP Tore Last10 For cc = 1 To 2 ' Home/Away strH = arM(zz, cc) & arS(zz, 1) ' Key = Team-ID&Saison If mDic.Exists(strH) Then arW = mDic(strH) mm = arW(12, 1) Mod 10 arW(10, 1) = arW(mm, 1) arW(mm, 1) = arErg(zz, 3 + cc) ' 10 Werte aus T:U arW(11, 1) = arErg(zz, 10 + cc) arW(12, 1) = arW(12, 1) + 1 If arErg(zz, 12 + cc) >= 10 Then _ arErg(zz, 24 + cc) = arW(10, 2) ' Torsumme arW(10, 2) = arW(10, 2) - arW(mm, 2) + arT(zz, cc) ' Torsumme arW(mm, 2) = arT(zz, cc) ' Tore mDic(strH) = arW

' ----------- Indizes 15 und 16 ---------------- Sp. AE:AF AnzSais H+A ' ----------- Indizes 21 und 22 ---------------- Sp. AK:AL Rat SaisBeg ' ----------- Indizes 23 und 24 ---------------- Sp. AM:AN Änd SaisBeg strH = arS(zz, 1) & arM(zz, cc) ' Key = Saison&Team If sDic.Exists(strH) Then arW = sDic(strH) arErg(zz, 14 + cc) = arW(1) arW(1) = arW(1) + 1 arErg(zz, 20 + cc) = arW(2) arErg(zz, 22 + cc) = arErg(zz, 3 + cc) - arW(2) sDic(strH) = arW Else

= 20 * Max(1, ((arErg(zz, 2)^2)^0.5))^0.5 * (arErg(zz, 7) - arErg(zz, 8)) = 20 * Max(1, (( R2^2)^0.5))^0.5 * (W2-X2) - wäre wohl dasselbe wie = 20 * Max(1, Abs(R2) )^0.5 * (W2-X2)

Hi Andre,
die nächste Stufe auf dem Treppchen ist wohl erreicht. Und hoffentlich stimmt jetzt auch noch Spalte Z...
Probier mal


Sub Dict_Diverses()
Dim mDic As Object, sDic As Object, aa As Long, arS, arT, arM, arErg()
Dim zz As Long, cc As Long, strH As String, arW, mm As Integer
Set mDic = CreateObject("Scripting.Dictionary")   ' Teams / next
Set sDic = CreateObject("Scripting.Dictionary")   ' Sais+Team / Anz
Sheets("TestTab").Select                                    ' testhalber
aa = Cells(Rows.Count, 15).End(xlUp).Row - 1
arS = Cells(2, 4).Resize(aa, 1)           ' D     Saison
arT = Cells(2, 8).Resize(aa, 2)           ' H:I   Tore Home+Away
arM = Cells(2, 15).Resize(aa, 2)          ' O:P   IDs  Home+Away
ReDim arErg(1 To aa, 1 To 28)
For zz = 1 To aa                 ' Zeilen
' ---------------------------------------------- Sp. Q Toto
If arT(zz, 1) > arT(zz, 2) Then
arErg(zz, 1) = 1
ElseIf arT(zz, 1) = 10 Then _
arErg(zz, 24 + cc) = arW(10, 2)                 ' Torsumme
arW(10, 2) = arW(10, 2) - arW(mm, 2) + arT(zz, cc) ' Torsumme
arW(mm, 2) = arT(zz, cc)                           ' Tore
mDic(strH) = arW
Else
ReDim arW(0 To 12, 1 To 2)
arW(0, 1) = arErg(zz, 3 + cc)       ' 1. Wert aus T:U
arW(11, 1) = arErg(zz, 10 + cc)
arW(12, 1) = 1
arW(0, 2) = arT(zz, cc)             ' Tore
arW(10, 2) = arT(zz, cc)            ' Torsumme
mDic.Add strH, arW
End If
' ----------- Indizes 17 und 18 ---------------- Sp. AG:AH RatVor10
' ----------- Indizes 19 und 20 ---------------- Sp. AI:AJ Verä Rat
If arErg(zz, 12 + cc) >= 10 Then
arErg(zz, 16 + cc) = arW(10, 1)
arErg(zz, 18 + cc) = arErg(zz, 3 + cc) - arW(10, 1)
End If
' ----------- Indizes 15 und 16 ---------------- Sp. AE:AF AnzSais H+A
' ----------- Indizes 21 und 22 ---------------- Sp. AK:AL Rat SaisBeg
' ----------- Indizes 23 und 24 ---------------- Sp. AM:AN Änd SaisBeg
' ----------- Indizes 27 und 28 ---------------- Sp. AQ:AR Tore Last10 Sais
strH = arS(zz, 1) & arM(zz, cc)  ' Key = Saison&Team
If sDic.Exists(strH) Then
arW = sDic(strH)
mm = arW(11) Mod 10
arErg(zz, 14 + cc) = arW(11)
arW(11) = arW(11) + 1
If arErg(zz, 14 + cc) >= 10 Then _
arErg(zz, 26 + cc) = arW(10)                    ' Torsumme
arW(10) = arW(10) - arW(mm) + arT(zz, cc)          ' Torsumme
arW(mm) = arT(zz, cc)                              ' Tore
arErg(zz, 20 + cc) = arW(12)
arErg(zz, 22 + cc) = arErg(zz, 3 + cc) - arW(12)
sDic(strH) = arW
Else
arErg(zz, 14 + cc) = 0
ReDim arW(0 To 12)
arW(11) = 1
arW(12) = arErg(zz, 3 + cc)
arErg(zz, 20 + cc) = arW(12)
arErg(zz, 22 + cc) = arErg(zz, 3 + cc) - arW(12)
arW(0) = arT(zz, cc)                ' Tore
arW(10) = arT(zz, cc)               ' Torsumme
sDic.Add strH, arW
End If
Next cc
Next zz
Cells(2, 17).Resize(aa, UBound(arErg, 2)) = arErg     ' Spalten Q:AR
End Sub

Noch eine Bemerkung: Fragen/Aufgaben und Code sind mittlerweile so speziell, dass das
kaum noch jemanden im Forum interessieren wird. Ich denke, dass der Code jetzt einigermaßen steht.
Wenn noch etwas zu tun ist, könnten wir das auch per Mail kommunizieren. Was meinst du?
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Beliebteste Forumthreads (12 Monate)

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread