Discussion :

[gg64480]

Appel aux Geeks de VBA. Mon expérience en programmation remontant à plusieurs dizaines d'année(Fortran), Je me suis mis récemment, pour une appli personnel, au VBA. Je pense pouvoir réaliser ce que je souhaite par une méthode un peu empirique, mais je pense qu'avec les méthodes VBA on peut faire quelque chose de plus beau. Voici le problème:

Dans le fichier joint, j'ai une liste de parties de golf de 4 joueurs, plusieurs parties par jour(4 ici) et 3 jours de compétition.

en sélectionnant un joueur quelconque dans la liste des joueurs présentée dans une ListBox, je souhaite faire apparaître, dans une autre liste , ou dans un Pop up la liste des joueurs avec lesquels ce joueur sélectionné n'a pas encore joué.

Merci à ceux qui auront pris la peine de regarder mon problème

[edelweisseric]

Bonsoir à tous
Bonsoir gg64480

Si j'ai bien compris ta demande, et suivant le fichier joint, voici un essai :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
Sub liste_joueurs()
Dim c As Range
Dim maplage As Range
 
Dim a As Integer
Dim i As Integer
Dim nb As Integer
Dim x As Integer
Dim y As Integer
 
Dim ligne As Integer
Dim nb_jours As Integer
Dim nb_parties_jour As Integer
 
Dim col As Integer
Dim L1 As Integer
Dim L2 As Integer
 
Dim les_joueurs As String
Dim nom_joueur As String
 
Dim Tablo()
 
' IMPERATIFS (comme sur le fichier modèle)
' le nom des parties sont en colonne "A"
' les jours en ligne "1"
' le début des saisies des joueurs en ligne "4"
' une ligne vide entre les joueurs de chaque chaque partie
 
nom_joueur = Range("A1")    ' nom du joueur à chercher. A modifier suivant l'emplacement
nb_parties_jour = Application.WorksheetFunction.CountA(Range("a3:a65536"))
nb_jours = Application.WorksheetFunction.CountA(Range("a4:iv4"))
 
nb = Application.WorksheetFunction.CountA(Range("B4").CurrentRegion)    ' un peu plus grand qu'il ne faut
 
ReDim Tablo(nb)
 
L1 = Range("B1").End(xlDown).Row
L2 = Range("B" & L1).End(xlDown).Row
col = 2
i = 0
For a = 1 To nb_parties_jour * nb_jours
    While Cells(L1 + 1, col) <> 0
        ligne = L1
        With Worksheets("Feuil1").Range(Cells(L1, col), Cells(L2, col))
            Set c = .Find(nom_joueur, LookIn:=xlValues, Lookat:=xlWhole)
            If Not c Is Nothing Then
                While i < L2 - (L1 - 1)
                    Tablo(x) = Cells(ligne, col)
                    x = x + 1
                    i = i + 1
                    ligne = ligne + 1
                Wend
                i = 0
            End If
        End With
        L1 = Range("B" & L2).Row + 2
        If Cells(Range("B" & L1).Row + 1, col) <> "" Then L2 = Range("B" & L1).End(xlDown).Row
    Wend
    If Cells(Range("B1").End(xlDown).Row + 1, col) <> 0 Then col = col + 1 Else Exit For
    L1 = Range("B1").End(xlDown).Row
    L2 = Range("B" & L1).End(xlDown).Row
Next
 
' la liste est en R1:R15. Modifier le "R1" et "R" et "R1", si la liste est dans une autre colonne
Set maplage = Range("R1:R" & Range("R1").End(xlDown).Row)
 
For y = 1 To Application.WorksheetFunction.CountA(maplage)
    If Not IsError(Application.Match(maplage(y), Tablo, 0)) = False Then
        If les_joueurs = "" Then
            les_joueurs = maplage(y)
        Else
            les_joueurs = les_joueurs & "," & maplage(y)
        End If
    End If
Next y
 
' le nom des joueurs sont dans la variable "les_joueurs"
MsgBox "Les joueurs avec qui " & nom_joueur & " n'a pas joué sont : " & vbLf & les_joueurs
 
End Sub

Certaines données seront à modifier.
C'est un peu long, il doit y avoir mieux.

Dis nous
Eric

[gg64480]

Merci Eric pour ta réponse. Je vais essayé de déchiffrer ton code. Pour ma part j'ai pris une direction différente en utilisant une Collection. J'ai une liste de joueurs ayant déjà joué avecle candidat. J'utilise la Collection pour éliminer les doublons. une erreur apparaît si un joueur est déjà présent dans le collection. Par ailleurs j'ai la liste des joueurs. C'est donc facile par des boucles de déterminer ceux qui n'ont jamais joué avec le candidat. Par contre je suis en train d'étudier la fonction FIND pour voir si c'est plus rapide et élégant que des boucles.

Cordialement
Gérard

[edelweisseric]

Bonjour à tous
Bonjour gg64480

Voici mon code avec quelques explications :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Sub liste_joueurs()
 
Option Explicit
Dim c As Range
Dim maplage As Range
 
Dim a As Integer
Dim i As Integer
Dim nb As Integer
Dim x As Integer
Dim y As Integer
 
Dim ligne As Integer
Dim nb_jours As Integer
Dim nb_parties_jour As Integer
 
Dim col As Integer
Dim L1 As Integer
Dim L2 As Integer
 
Dim les_joueurs As String
Dim nom_joueur As String
 
Dim Tablo()
 
' IMPERATIFS (comme sur le fichier modèle)
' le numérotage des parties est en colonne "A"
' les jours en ligne "1"
' le début des saisies des joueurs en cellule "B4"
' une ligne vide entre les joueurs de chaque partie
 
nom_joueur = Range("A1")    ' nom du joueur à chercher. A modifier suivant l'emplacement
nb_parties_jour = Application.WorksheetFunction.CountA(Range("a3:a65536"))
nb_jours = Application.WorksheetFunction.CountA(Range("a4:iv4"))
 
nb = Application.WorksheetFunction.CountA(Range("B4").CurrentRegion)    ' un peu plus grand qu'il ne faut
 
ReDim Tablo(nb)
 
' 1ère ligne de la partie
L1 = Range("B1").End(xlDown).Row
' dernière ligne de la partie
L2 = Range("B" & L1).End(xlDown).Row
 
col = 2
i = 0
 
' boucle sur le nb de parties
For a = 1 To nb_parties_jour * nb_jours
    ' vérification que la ligne suivante ne soit pas égale à 0 => fin des saisies de la colonne
    While Cells(L1 + 1, col) <> 0
        ligne = L1
        ' recherche du nom du joueur dans la partie
        ' puis balayage des parties du jour
        With Worksheets("Feuil1").Range(Cells(L1, col), Cells(L2, col))
            Set c = .Find(nom_joueur, LookIn:=xlValues, Lookat:=xlWhole)
            If Not c Is Nothing Then
                ' si oui on place TOUS les noms des joueurs de la partie dans tablo
                While i < L2 - (L1 - 1)
                    Tablo(x) = Cells(ligne, col)
                    x = x + 1
                    i = i + 1
                    ligne = ligne + 1
                Wend
                i = 0
            End If
        End With
        ' réinitialisation de L1 et L2 pour la partie suivante dans la même colonne
        L1 = Range("B" & L2).Row + 2
        If Cells(Range("B" & L1).Row + 1, col) <> "" Then L2 = Range("B" & L1).End(xlDown).Row
    Wend
    ' passage à la colonne suivante
    If Cells(Range("B1").End(xlDown).Row + 1, col) <> 0 Then col = col + 1 Else Exit For
    ' réinitialisation de L1 et L2 pour la colonne suivante
    L1 = Range("B1").End(xlDown).Row
    L2 = Range("B" & L1).End(xlDown).Row
Next
 
' la liste des joueurs, pour mon exemple, est en R1:R15. Modifier le "R1" et "R" et "R1", si la liste est dans une autre colonne
Set maplage = Range("R1:R" & Range("R1").End(xlDown).Row)
 
' boucle sur la totalité des noms de joueurs
For y = 1 To Application.WorksheetFunction.CountA(maplage)
    ' recherche si chaque nom de la liste des joueurs est dans le tablo
    If Not IsError(Application.Match(maplage(y), Tablo, 0)) = False Then
        ' si il n'y est pas, le nom du joueur est mis dans la variable "les_joueurs"
        ' mais on pourrait les mettre dans un nouveau "tablo1"
        ' le If est pour la présentation
        If les_joueurs = "" Then
            ' le nom du premier joueur
            les_joueurs = maplage(y)
        Else
            ' le nom des joueurs suivants
            les_joueurs = les_joueurs & ", " & maplage(y)
        End If
    End If
Next y
 
MsgBox "Les joueurs avec qui " & nom_joueur & " n'a pas joué sont : " & vbLf & les_joueurs
 
End Sub

Eric

[Docmarti]

Bonjour Gérard.

Sur le principe de la Collection, j'ai utilisé le Scripting.dictionary pour créer la liste de tous les joueurs. De laquelle il ne reste qu'à supprimer le joueur lui-même et ceux avec qui il a joué. Il reste donc ceux avec qui il n'a pas joué.

Cordialement

Docmarti.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
'Reference a Microsoft Scripting Runtime
 
Sub tt(jr)
Application.EnableEvents = False
 
Set Dico = CreateObject("Scripting.dictionary")
 
Set f = ThisWorkbook.Worksheets("feuil1")
Set u = f.UsedRange
 
For Each c In u
 If c.Row > 3 And c.Column > 1 Then
  If c.Value <> "" Then
   If Not Dico.Exists(c.Value) Then Dico.Add c.Value, c.Value
  End If
 End If
 Next c
 
If Dico.Exists(jr) Then
    Dico.Remove (jr)
End If
 
cols = u.Columns.Count
 
For colo = 2 To u.Columns.Count
 
 ligvide = 1 '3
 Set Rvide = f.Cells(ligvide, colo)
'prochaine cellule non-vide
 Set premnonvide = Rvide.End(xlDown) 'Premier élément. Attention. Équvalent de CTRL+Flèche vers le bas
 'S'arrête sur le premier élément non vide suivant ou précédant une cellule vide
 
 Do While premnonvide.Value <> ""
 
Set dernierenonvide = premnonvide.End(xlDown) 'Dernier élément
 
Set where = f.Range(premnonvide, dernierenonvide)
 
Set rg = Nothing
    Set rg = where.Find(what:=jr, LookIn:=xlValues, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
 
 
    If Not rg Is Nothing Then
 
    For Each cell In where
 
    If Dico.Exists(cell.Value) Then
     Dico.Remove (cell.Value)
    End If
 
    Next
End If
 
Set premnonvide = dernierenonvide.End(xlDown) 'Nouveau premier élément
 
 Loop
 
 Next
 
Message = jr & " n'a pas joue avec " & vbCrLf & vbCrLf
    k = Dico.Keys
    i = Dico.Items
    For n = 0 To Dico.Count - 1
     Message = Message & n + 1 & " " & k(n) & ", " & i(n) & vbCrLf
    Next n
    MsgBox Message
 
 
Application.EnableEvents = True
End Sub
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set t = Target
 
If t.Count = 1 And t.Column > 1 And t.Row > 1 Then
 If t.Value <> "" Then
  jr = t.Value
  Call tt(jr)
 End If
End If
End Sub

[Invité]

Bonjour, test ça