Turnerings udregning

http://www.eksperten.dk/spm/210540

Jeg har lavet en xlt-skabelon med to ark.

Ark1 indeholder en knap kaldet cmdOpdaterStilling
På ark1 er kampprogrammet indtastet.
Resultatet indtastes i kolonnerne C - D. Det ene holds score i C og det andet holds score i D.
-------------------------------------------------
    A      B
1  Hold1  Hold2    +------------------+
2  Hold3  Hold4    | Opdater stilling |
3                    +------------------+
4  Hold1  Hold3
5  Hold2  Hold4
6
7  Hold1  Hold4
8  Hold2  Hold3

Ark2 indeholder stillingen. Navnene i stillingen skal svarre til navnene i stillingen. (case sensitive)
-------------------------------------------------
      A      B    C  D  E  F  G  H  I  J
1  Plac.  Hold  K  V  U  T  MF  MI  MD  P
2  1        Hold1  0  0  0  0  0  0  0  0
3  2        Hold2  0  0  0  0  0  0  0  0
4  3        Hold3  0  0  0  0  0  0  0  0
5  4        Hold4  0  0  0  0  0  0  0  0

Kode i ThisWorkbook
-------------------------------------------------
Option Explicit

Const PLACERING As Integer = 1
Const HOLDNAVN  As Integer = 2
Const KAMPE    As Integer = 3
Const VUNDNE    As Integer = 4
Const UAFGJORT  As Integer = 5
Const TABTE    As Integer = 6
Const MÅLFOR    As Integer = 7
Const MÅLMOD    As Integer = 8
Const MÅLDIF    As Integer = 9
Const POINT    As Integer = 10

Dim Hold1, Hold2  As String
Dim Mål1, Mål2    As String
Dim Point1, Point2 As Integer

Sub SorterStilling()
 
  Dim antalRækker As Integer
 
  antalRækker = Ark2.Range("A1").CurrentRegion.Rows.Count
 
  Ark2.Range(Ark2.Cells(1, HOLDNAVN), Ark2.Cells(antalRækker, POINT)).Sort _
      Key1:=Ark2.Cells(1, POINT), Order1:=xlDescending, _
      Key2:=Ark2.Cells(1, MÅLDIF), Order2:=xlDescending, _
      Key3:=Ark2.Cells(1, VUNDNE), Order3:=xlDescending, _
      Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
     
End Sub

Sub OpdaterStilling()

  Dim i As Integer
 
  For i = 1 To Ark2.Cells(1, PLACERING).CurrentRegion.Rows.Count
        If Ark2.Cells(i, HOLDNAVN).Value = Hold1 Then
            Ark2.Cells(i, KAMPE).Value = Ark2.Cells(i, KAMPE).Value + 1
            Select Case Point1
              Case 3
                  Ark2.Cells(i, VUNDNE).Value = Ark2.Cells(i, VUNDNE).Value + 1
              Case 1
                  Ark2.Cells(i, UAFGJORT).Value = Ark2.Cells(i, UAFGJORT).Value + 1
              Case 0
                  Ark2.Cells(i, TABTE).Value = Ark2.Cells(i, TABTE).Value + 1
            End Select
            Ark2.Cells(i, MÅLFOR).Value = Ark2.Cells(i, MÅLFOR).Value + Mål1
            Ark2.Cells(i, MÅLMOD).Value = Ark2.Cells(i, MÅLMOD).Value + Mål2
            Ark2.Cells(i, MÅLDIF).Value = Ark2.Cells(i, MÅLDIF).Value + (Mål1 - Mål2)
            Ark2.Cells(i, POINT).Value = Ark2.Cells(i, POINT).Value + Point1
        End If
       
        If Ark2.Cells(i, HOLDNAVN).Value = Hold2 Then
            Ark2.Cells(i, KAMPE).Value = Ark2.Cells(i, KAMPE).Value + 1
            Select Case Point2
              Case 3
                  Ark2.Cells(i, VUNDNE).Value = Ark2.Cells(i, VUNDNE).Value + 1
              Case 1
                  Ark2.Cells(i, UAFGJORT).Value = Ark2.Cells(i, UAFGJORT).Value + 1
              Case 0
                  Ark2.Cells(i, TABTE).Value = Ark2.Cells(i, TABTE).Value + 1
            End Select
            Ark2.Cells(i, MÅLFOR).Value = Ark2.Cells(i, MÅLFOR).Value + Mål2
            Ark2.Cells(i, MÅLMOD).Value = Ark2.Cells(i, MÅLMOD).Value + Mål1
            Ark2.Cells(i, MÅLDIF).Value = Ark2.Cells(i, MÅLDIF).Value + (Mål2 - Mål1)
            Ark2.Cells(i, POINT).Value = Ark2.Cells(i, POINT).Value + Point2
        End If
  Next i
 
End Sub

Sub UdregnLiga()
 
  Ark1.Activate
  Ark1.Range("A1").Activate
 
  While ActiveCell.Value <> "" Or ActiveCell.Offset(1, 0).Value <> ""
 
      If ActiveCell.Offset(0, 2) <> "" And ActiveCell.Offset(0, 3) <> "" And ActiveCell.Offset(0, 5) <> "1" Then
        Hold1 = ActiveCell.Value
        Hold2 = ActiveCell.Offset(0, 1).Value
     
        Mål1 = ActiveCell.Offset(0, 2).Value
        Mål2 = ActiveCell.Offset(0, 3).Value
 
        If Mål1 > Mål2 Then
            Point1 = 3
            Point2 = 0
        ElseIf Mål2 > Mål1 Then
            Point2 = 3
            Point1 = 0
        Else
            Point1 = 1
            Point2 = 1
        End If
     
        OpdaterStilling
     
        ActiveCell.Offset(0, 5) = "1"
      End If
       
      ActiveCell.Offset(1, 0).Activate
  Wend
 
  SorterStilling
 
End Sub

Kode i Ark1
-------------------------------------------------
Private Sub cmdOpdaterStilling_Click()
  Call ThisWorkbook.UdregnLiga
End Sub

Jeg kan sende den til dig i en mail hvis det er nemmere

Navnene i stillingen skal svarre til navnene i kamprogrammet. Det var det jeg mente!

vil du sende et eks. til mig. Så vil jeg blive glad :-)
dhk05 snabel a hotmail.com

Den er sendt... Basket.xlt

Mange tak.
Det kan jeg ihvertfald bruge.

Det var så lidt...
Dete glæder mig!

er du da helt gal !!!!!! 1000000000000 og mange gange flere tak tholjoh. Jeg vil gerne have den sendt som email, hvis det kan lade sig gøre. Kan du lave det samme med flere hold i en "liga". Håber jeg må spørge dig til råds via mail, hvis det bliver nødvendigt.

Min mail kimriber snabel a gmail.com

Igen mange tak

KR/PB

Den er sendt...

Du spørger bare!

kan jeg få en kopi til min søn for 15 point ? ,så opretter jeg et spørgsmål

Naturligvis

Hvordan giver man point. Jeg skylder tholjoh en masse point.

markere tholjoh i boksen til venstre og klikker på acceptere.

sig til når du er klar, så opretter jeg en der hedder 'Point til tholjoh'

pm@madsen.tdcadsl.dk

Jeg er klar.
Og den er sendt.

ok øjeblik

@tholjoh
Har du stadig denne fil ?? Jeg kunne godt tænke mig en kopi, for det ligner sådan et program jeg også har brug for :-)
Har prøvet selv at "klippe klistre" det, men det gik ikke ;-)

-Jesper