Copier un tableau et le reduire
Bonjour le forum
quand le tirage au sort est fait pas macro
Sur la feuille Série il y a le tableau des rencontres dans la colonne N° c'est le numéro des équipes puis 4 colonne avec les rencontres
si on regarde le tirage de la serie1 on voit
1 contre 77
2 contre 16
3 contre 45
4 contre 81
5 contre 71
6 contre 89
7 contre 88
8 contre 74
9 contre 35
10 contre 13
11 contre 75
12 contre 47
13 contre 10
14 contre 85
15 contre 30
16 contre 2
17 contre 43
etc etc
je voudrai recopier ce tableau et le réduire de moitié
1 contre 77
2 contre 16
3 contre 45
4 contre 81
5 contre 71
6 contre 89
7 contre 88
8 contre 74
9 contre 35
10 contre 13
11 contre 75
12 contre 47
14 contre 85
15 contre 30
17 contre 43
etc etc
je voudrais copier le tableau en supprimant les lignes qui sont en double voir exemple ci dessus
je doit garder le tableau principale qui est la feuille Série
Quelle formule doit utiliser
je vous remercie d'avance
cordialement
Wazizou
Bonsoir gmb
ton fichier est bon juste un petit probleme
si il y a moins de 100 equipes ca ne marche pas
Cordialement
Wazizou
Il n'y a pas de raison...si il y a moins de 100 equipes ca ne marche pas
Ci joint un exemple avec 50 équipes.
Bye !
Bonjour gmb et le forum
j ai testé ton fichier et je trouve deux problèmes
le premier : si il y a 100 équipe il réduit le tableau sur 98 équipes pas sur 100
le deuxième : si je fait une nouvelle partie quand le tirage se fait sa rempli le tableau dans la feuille Série et quand je lance la macro extraire
sa bug
comment modifier la macro
pourrez vous mettre des explications sur la macro pour que je puisse comprendre comment elle marche
cordialement
Wazizou
Bonjour
Voilà :pourrez vous mettre des explications sur la macro pour que je puisse comprendre comment elle marche
Sub Extraire()
tablo = Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row) 'On met les données de la colonne B dans une variable tablo
Set dico = CreateObject("Scripting.Dictionary") 'On crée un dictionnaire pour avoir une liste sans doublon
For num = 3 To 6 'On va passer les données des colonnes 3 à 6 (C à F)
tabloV = Range(Cells(3, num), Cells(Cells(Rows.Count, num).End(xlUp).Row, num)) 'On met les données de la colonne condidérée dans une variable tablo
For i = 1 To UBound(tablo, 1) - 1 'On va passer toutes les cellules de la colonne
If Not dico.exists(tabloV(i, 1) & "_" & tablo(i, 1)) Then 'On fait un test pour ne retenir que les valeurs de lignes dont l'inverse des colonnes
'n'existe pas dans le dictionnaire
dico(tablo(i, 1) & "_" & tabloV(i, 1)) = "" 'On met dans le dictionnaire un nom composé des 2 colonnes espacés d'un underscore
End If
Next i
k = dico.keys 'variable qui permettra de récupérer la clé d'une valeur du dictionnaire
ReDim tabloR(1 To dico.Count, 1 To 2) 'On définit la taille du tableau de résultats pour la colonne considérée
For i = 1 To dico.Count - 1 'On va passer toutes les valeurs du dictionnaire
tabloR(i, 1) = Val(Split(k(i - 1), "_")(0)) 'pour chaque valeur de clé du dictionnaire, on décompose la valeur et on met
'la 1° partie dans la 1° colonne du tableau de résultat
tabloR(i, 2) = Val(Split(k(i - 1), "_")(1)) 'On fait pareil pour la 2° partie qu'on met dans la 2° colonne
Next i
Cells(3, 4 * num - 3).Resize(dico.Count + 1, 2).ClearContents 'On efface la zone de résutat pour l'initialiser
Cells(3, 4 * num - 3).Resize(dico.Count, 2) = tabloR 'On y écrit le tableau de résultat
Erase tabloV 'on réinitialise la variable tabloV qui va servir à la colonne suivante : D puis E et F
dico.RemoveAll 'pareil pour le dictionnaire
Next num
End SubEt fais attention !
Si tu effaces les valeurs de ton tableau pou le réduire, il y a une formule dans la ligne qui suit la dernière.
On la croit vide mais ne l'est pas et la macro la prend toujours pour la dernière ligne du tableau avant réduction.
Bye !
bonjour gmb et le forum
merci pour les explications
le probleme que c est pas moi qui est fait ce fichier je l ai récupéré sur le net
Quand il y a 100 equipes la derniere cellule b103 ne contient pas de formule et la reduction se fait que sur 98 equipes et non sur 100
y a t il une solution pour faire croire a la macro qu il n y a pas de formule après la dernier ligne remplie
cordialement
Wazizou
Bonsoir gmb et le forum
Les valeurs arrivent dans les colonnes C, D, E et F sur la feuille "Séries avec la macro suivante qui se déclenche quand on clic sur le bouton fin inscription qui se trouve sur l Userfrom inscription pour accéder a l userfrom principale on clic sur le bouton page principal qui se trouve sur la feuille "Equipe"
Option Explicit
'Ti Thierry Pourtier - xlti@wanadoo.fr
'30 décembre 2003 - usage perso
'adapté pour Vériti le 25 novembre 2005
'http://veriti.free.fr
'le nombre de parties du tournoi
Const KNbPart = 4
Const KBB = "0"
Dim TablPart(), NbJ%
Private Function OKTirage(J1%, J2%, Part%) As Boolean 'Ti
Dim Bcle%
For Bcle = 1 To Part
If TablPart(J1, Bcle) = J2 Then Exit Function
Next Bcle
OKTirage = True
End Function
Private Function InitStr$(Lg%) 'Ti
Do: InitStr = InitStr & Chr(Len(InitStr) + 1): Loop Until Len(InitStr) = Lg
End Function
Private Sub PlaceBB() 'Ti
Dim Bcle%
For Bcle = 1 To KNbPart: TablPart(TablPart(NbJ, Bcle), Bcle) = KBB: Next Bcle
End Sub
Private Function TirageParties() As Boolean 'Ti
Dim Bcle%, Part%, J1%, J2%
Dim StrN$, Alea%, NbTry%
For Part = 1 To KNbPart
StrN = InitStr(NbJ)
For Bcle = 1 To NbJ / 2
NbTry = 0
J1 = Asc(Mid(StrN, 1, 1)): StrN = Mid(StrN, 2)
Do
Alea = Int((Rnd * Len(StrN)) + 1): J2 = Asc(Mid(StrN, Alea, 1))
NbTry = NbTry + 1: If NbTry = 50 Then Exit Function
Loop Until OKTirage(J1, J2, Part)
TablPart(J1, Part) = J2: TablPart(J2, Part) = J1
StrN = Mid(StrN, 1, Alea - 1) & Mid(StrN, Alea + 1)
Next Bcle
Next Part
TirageParties = True
End Function
Sub TirageAleatoire() 'Ti
Const KErr = vbObject + 50
Dim Odd As Boolean, Msg$
Randomize
On Error GoTo erreur
NbJ = F1.Range("NbJoueurs")
If NbJ < 5 Or NbJ > 100 Then Err.Raise KErr
Odd = NbJ Mod 2 <> 0: If Odd Then NbJ = NbJ + 1
ReDim TablPart(1 To NbJ, 1 To KNbPart)
Do: Loop Until TirageParties
If Odd Then PlaceBB
Application.ScreenUpdating = False
With F2
'.Unprotect
With .Range("Séries")
.ClearContents: .Resize(NbJ, KNbPart).Value = TablPart
End With
'.Protect:
Application.GoTo .Range("A1"), True
End With
Beep
Application.ScreenUpdating = True
Exit Sub
erreur:
If Err.Number = KErr Then Msg = ", il faut entre 6 et 100 équipes..." Else Msg = " durant le tirage des parties"
MsgBox "Erreur" & Msg, vbCritical, "Tirage Belote"
End SubLe tableau de la feuille Série sers aussi pour rentrer les point de chaque partie avec l userfrom Points
la formule qui se trouve dans les cellules de la colonne B de la feuilles Séries sert a dectecter si il y a un nombre impair des equipe ce qui permet de mettre un zero pour avoir un nombre pair et defini l equipe qui ne joue pas et lui attribut 1000 point d office
=SI(C4="";"";SI(C5<>"";B3+1;SI(NbJoueurs=PAIR(NbJoueurs);B3+1;"0")))
pour ton dernier fichier il ne réduit plus rien
je te joint un fichier ou j ai inscris 20 équipes il te restera plus qu a cliquer sur le bouton fin inscription pour déclencher la macro comme tu verras comment ça ce passe
Cordialement
Wazizou
bonsoir gmb et le forum
je viens de teste ton fichier ça fonction mais il y a un toujours un probleme
ca réduit bien le tableau comme je veux mais il rajoute des rencontre qui n existe pas
j ai surligner les mauvais rencontre en rouge les autre qui sont surligner de couleur différente sont bonne
cordialement
Wazizou
Bonjour gmb et le forum
Je viens de comprendre pourquoi il rajoute
Les rencontre qui n existe pas
Dans la macro il faut enlever la partie recherche
Numéro manquant
Un grand merci pour ton aide
Cordialement
Wazizou