Problème dans ce code

Version imprimable

Bonsoir le forum,

J'ai un ce code qui me classe les résultats des séries dans ma feuille Finale, le problème, comme c'est le même code qui me classe les résultats des séries dans la feuille demi finale, et que j'ai fait un copier coller de ce code, je voulais savoir ce qu'il faut changer pour qu'il me fasse un classement sur un poule de 6 lignes maxi car la , il me les classe en 2 poules.
j'espère avoir été assez explicite.
merci d'avance.
Voici le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Public Sub RESULT1_F(ByRef ws As Worksheet, ByVal num As Byte)
Dim sht As Worksheet, shtf As Worksheet
Dim LL As Integer, i As Integer, FinPrem As Integer
Dim LigF As Byte, ColF As Byte
Dim tour As Boolean
 
Application.ScreenUpdating = False
NbPoules = num
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = False
 
Set sht = Worksheets.Add
sht.Name = "Temp"
 
UsfDF2.Show
 
With ws
    For i = 1 To num
        .Range(.Cells(6, 5 * i - 4), .Cells(5 + Opt, 5 * i - 1)).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
        For i = 1 To num
        LL = .Cells(5, 5 * i - 4).End(xlDown).Row
        .Range(.Cells(6 + Opt, 5 * i - 4), .Cells(LL, 5 * i - 1)).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
End With
 
With sht
        FinPrem = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A" & Opt * num + 2 & ":D" & FinPrem).Sort Key1:=.Range("D" & Opt * num + 2), Order1:=xlAscending, Header:=xlNo
End With
 
LigF = 6: ColF = 1
tour = True
 
Set shtf = Sheets("Finales")
With shtf
    .Range("A6:D12").Clear 'Contents
    For i = 2 To NbF + 1
        sht.Range("A" & i & ":C" & i).Copy .Cells(LigF, ColF)
        tour = Not tour
        If tour Then
            LigF = LigF + 1
        Else
            ColF = IIf(ColF = 6, 1, 6)
        End If
    Next i
End With
 
Application.DisplayAlerts = False
sht.Delete
Application.DisplayAlerts = False
shtf.Activate
Set sht = Nothing
Set shtf = Nothing
End Sub

jacky

13/02/2010, 15h18
jacfld49

bonjour le forum,

mon titre n'est surement pas bon car en fait, le code que j'ai, me tri bien la feuille Demi Finale et ensuite fait le classement en Feuille Finale, mais je voudrais en fait que sur le même principe: Grace à un USF, il me demande si je veux envoyer les 1er de chaque demi finale puis les meilleurs temsp ou les 1er et 2 ème et les meilleurs temps ou les 1er, 2ème et 3ème avec un maxi de 6 patineurs en finale mais à la place de me les classer en 2 poules, il ne me fait qu'une poule.

merci
jacky

bonsoir le forum,

comment puis je améliorer ce code pour qu'il ne me fasse qu'une seule poule.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Public Sub RESULT1_F(ByRef ws As Worksheet, ByVal num As Byte)
Dim sht As Worksheet, shtf As Worksheet
Dim LL As Integer, i As Integer, FinPrem As Integer
Dim LigF As Byte, ColF As Byte
Dim tour As Boolean
 
Application.ScreenUpdating = False
NbPoules = num
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = False
 
Set sht = Worksheets.Add
sht.Name = "Temp"
 
UsfDF2.Show
 
With ws
    For i = 1 To num
        .Range(.Cells(6, 5 * i - 4), .Cells(5 + Opt, 5 * i - 1)).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
        For i = 1 To num
        LL = .Cells(5, 5 * i - 4).End(xlDown).Row
        .Range(.Cells(6 + Opt, 5 * i - 4), .Cells(LL, 5 * i - 1)).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
End With
 
With sht
        FinPrem = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A" & Opt * num + 2 & ":D" & FinPrem).Sort Key1:=.Range("D" & Opt * num + 2), Order1:=xlAscending, Header:=xlNo
End With
 
LigF = 6: ColF = 1
tour = True
 
Set shtf = Sheets("Finales")
With shtf
    .Range("A6:D12").Clear 'Contents
    For i = 2 To NbF + 1
        sht.Range("A" & i & ":C" & i).Copy .Cells(LigF, ColF)
        tour = Not tour
        If tour Then
            LigF = LigF + 1
        Else
            ColF = IIf(ColF = 6, 1, 6)
        End If
    Next i
End With
 
Application.DisplayAlerts = False
sht.Delete
Application.DisplayAlerts = False
shtf.Activate
Set sht = Nothing
Set shtf = Nothing
End Subjacky

merci
jacky