Tirage au sort sans les blancs

S

speedball

XLDnaute Junior
Bonjour

Je me dirige vers vous pour un coup de main.
Je souhaite faire un tirage aléatoire des cellules non vide (B6-B37) feuille inscriptions
avec un résultat sur la feuille appelé comme la cellule M2
Je joins un fichier Exemple
Je suis dans le flou complet
Malgrès les nombreux post existants, je n'y arrive pas

Merci
 

Pièces jointes

  • Ex1.xls
    16.5 KB · Affichages: 102
  • Ex1.xls
    16.5 KB · Affichages: 98
  • Ex1.xls
    16.5 KB · Affichages: 95
Trier par date Trier par votes
P

pat01200

XLDnaute Occasionnel
Re : Tirage au sort sans les blancs

Bonjour Speedball,

J'ai écrit le code nécessaire dans ton fichier, fais des essais et dis-moi si cela te convient...
 

Pièces jointes

  • Ex1(1).xls
    39.5 KB · Affichages: 106
  • Ex1(1).xls
    39.5 KB · Affichages: 106
  • Ex1(1).xls
    39.5 KB · Affichages: 112
Vote positif 0 Vote négatif
S

speedball

XLDnaute Junior
Re : Tirage au sort sans les blancs

Merci

J'ai un souci, quand j'ai voulu mettre cette macro dans mon fichier.
Il me dit que certaines cellules sont vérouillés, si je déverouille les cellules la macro fonctionne.
comment faire pour déproteger la feuille et la reproteger à la fin.
De plus sur la feuille "1er", j'ai des lignes qui se retrouve supprimées ou maquées
J'ai donc tenter de modifier la macro pour que le résultatne soit plus de B1 à B32 de la feuille 1er mais dans les cellules B101 à B132 de la feuille Inscriptions. Je n'ai pas réussi, peut tu m'aider?

Mais un grand merci pour ce travail déjà réalisé
 
Dernière édition:
Vote positif 0 Vote négatif
P

pat01200

XLDnaute Occasionnel
Re : Tirage au sort sans les blancs

Bonjour,
Voici la façon de procéder pour la protection :
Au début de la macro, tu rajoutes :
ActiveSheet.Unprotect
et à la fin
ActiveSheet.Protect
Si la protection se fait avec mot de passe, les codes sont :
ActiveSheet.Unprotect Password:="Mon_mot_de_passe"et
ActiveSheet.Protect Password:="Mon_mot_de_passe"
Pour le reste, les lignes supprimées correspondent à tes blancs de départ
 
Vote positif 0 Vote négatif
S

speedball

XLDnaute Junior
Re : Tirage au sort sans les blancs

Je mouline lorsque je modifie la macro
pour que le résultat soit sur la même feuille
je me retrouve avec des lignes de hauteur 0 (je crois)
et les numéros de lignes deviennent bleu ???
Je crois que ces la sélection de la colonne B qui pose problème
Voici que j'ai modifié

Sub Tirage()
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Sheets("Inscriptions").Select
Range("B100").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="<>"
Range("B6:B37").Select
Selection.Copy
Range("B101").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A100").Select
ActiveCell.FormulaR1C1 = "=4*RAND()"
Range("A100").Select
Selection.Copy
Range("A101:A131").Select
ActiveSheet.Paste
Range("A100:B131").Select
Selection.Sort Key1:=Range("A100"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("Inscriptions").Select
Selection.AutoFilter
Range("B100").Select
Sheets("Inscriptions").Select
Columns("B:B").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="="
Range("B101:B133").Select
Selection.EntireRow.Delete
Range("B101").Select
Sheets("Inscriptions").Select
Range("B100").Select
Application.ScreenUpdating = True
MsgBox " Tirage effectué avec succès ! "
ActiveSheet.Protect
End Sub


Merci
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Tirage au sort sans les blancs

Bonjour à tous
Essayez ceci :
Code: 
[COLOR="DarkSlateGray"][B]Sub Macro1()
Dim i&, Table(), sDat(), oColl As New Collection, plg As Object
  With Sheets("Inscriptions") [COLOR="Sienna"]'Feuille d'origine.[/COLOR]
    .Unprotect [COLOR="Sienna"]'*si besoin est.[/COLOR]
    Table = .[B6:B37].Value 'Données.
    .Protect [COLOR="Sienna"]'*si besoin est.[/COLOR]
  End With
  On Error Resume Next
  For i = 1 To UBound(Table, 1)
    If Not IsEmpty(Table(i, 1)) And Table(i, 1) <> "" Then oColl.Add Table(i, 1), CStr(Table(i, 1))
  Next i
  ReDim sDat(1 To oColl.Count, 1 To 1)
  i = 0
  On Error GoTo 0
  Randomize
  Do While oColl.Count > 0
    i = i + 1
    sDat(i, 1) = oColl(1 + Int(oColl.Count * Rnd))
    oColl.Remove 1 + Int(oColl.Count * Rnd(0))
  Loop
  Set plg = Sheets("Inscriptions") [COLOR="Sienna"]'Feuille de destination[/COLOR]
  plg.Unprotect [COLOR="Sienna"]'*si besoin est.[/COLOR]
  With plg.[B101] [COLOR="Sienna"]'Cellule de destination[/COLOR]
    .Value = " "
    .Resize(plg.Cells(plg.Rows.Count, .Column).End(xlUp).Row - .Row + 1, 1).ClearContents
    .Resize(UBound(sDat, 1), 1).Value = sDat
  End With
  plg.Protect [COLOR="Sienna"]'*si besoin est.[/COLOR]
End Sub[/B][/COLOR]
C'est aisément adaptable (voir les commentaires).​
ROGER2327
#4345

Dimanche 15 Haha 138 (Nativité de l' Œstre, artificier, ST)
29 Vendémiaire An CCXIX
2010-W42-3T13:45:44Z
 
Dernière édition:
Vote positif 0 Vote négatif
S

speedball

XLDnaute Junior
Re : Tirage au sort sans les blancs

Bonjour

Je souhaite changer la destination par un nom de feuille qui est une variable = au contenu de la cellule M2 de la feuille Inscriptions. J'ai donc tenter de tenter de changer la macro, mais ca plante sur sur cette ligne Rows("100:140").Select

VOICI le code modifié

code:
Sub Tirage()
Dim i&, Table(), sDat(), oColl As New Collection, plg As Object
With Sheets("Inscriptions") 'Feuille d'origine.
.Unprotect '*si besoin est.
Table = .[B6:B37].Value 'Données.
.Protect '*si besoin est.
End With
On Error Resume Next
For i = 1 To UBound(Table, 1)
If Not IsEmpty(Table(i, 1)) And Table(i, 1) <> "" Then oColl.Add Table(i, 1), CStr(Table(i, 1))
Next i
ReDim sDat(1 To oColl.Count, 1 To 1)
i = 0
On Error GoTo 0
Randomize
Do While oColl.Count > 0
i = i + 1
sDat(i, 1) = oColl(1 + Int(oColl.Count * Rnd))
oColl.Remove 1 + Int(oColl.Count * Rnd(0))
Loop
Dim j As String
j = Range("Inscriptions!M2").Value
Set plg = Sheets(j) 'Feuille de destination
Sheets(j).Unprotect '*si besoin est.
Rows("100:140").Select
Selection.EntireRow.Hidden = False
With plg.[B101] 'Cellule de destination
.Value = " "
.Resize(plg.Cells(plg.Rows.Count, .Column).End(xlUp).Row - .Row + 1, 1).ClearContents
.Resize(UBound(sDat, 1), 1).Value = sDat
End With
Rows("100:140").Select
Selection.EntireRow.Hidden = True
Sheets(j).Protect '*si besoin est.
MsgBox " Tirage effectué avec succès ! "
End Sub


Quelqu'un peut-il m'aider

Merci d'avance
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Tirage au sort sans les blancs

Re...
speedball à dit:
(...)
Je souhaite changer la destination par un nom de feuille qui est une variable = au contenu de la cellule M2 de la feuille Inscriptions. J'ai donc tenter de tenter de changer la macro, mais ca plante sur sur cette ligne Rows("100:140").Select
(...)
Cliquez pour agrandir...
Changer le nom de la feuille de destination n'est pas vraiment le problème puisque le code est prévu pour cela. Le problème est de savoir à quelle feuille appartient la plage Rows("100:140") que vous voulez traiter, ce que vous ne dites pas. En supposant qu'il s'agit de la feuille de destination (nommée en M2 de la feuille Inscriptions), essayez ce code :
Code: 
[COLOR="DarkSlateGray"][B]Sub Tirage()
Dim i&, [COLOR="Red"]j$,[/COLOR] Table(), sDat(), oColl As New Collection, plg As Object
  With Sheets("Inscriptions") 'Feuille d'origine.
    .Unprotect '*si besoin est.
    Table = .[B6:B37].Value 'Données.
    [COLOR="Red"]j = Range("M2").Value[/COLOR]
    .Protect '*si besoin est.
  End With
  On Error Resume Next
  For i = 1 To UBound(Table, 1)
    If Not IsEmpty(Table(i, 1)) And Table(i, 1) <> "" Then oColl.Add Table(i, 1), CStr(Table(i, 1))
  Next i
  ReDim sDat(1 To oColl.Count, 1 To 1)
  i = 0
  On Error GoTo 0
  Randomize
  Do While oColl.Count > 0
    i = i + 1
    sDat(i, 1) = oColl(1 + Int(oColl.Count * Rnd))
    oColl.Remove 1 + Int(oColl.Count * Rnd(0))
  Loop
  Set plg = Sheets(j) 'Feuille de destination
  [COLOR="Red"]plg[/COLOR].Unprotect '*si besoin est.
  [COLOR="Red"]plg.[/COLOR]Rows("100:140").EntireRow.Hidden = False
  With plg.[B101] 'Cellule de destination
    .Value = " "
    .Resize(plg.Cells(plg.Rows.Count, .Column).End(xlUp).Row - .Row + 1, 1).ClearContents
    .Resize(UBound(sDat, 1), 1).Value = sDat
  End With
  [COLOR="Red"]plg.[/COLOR]Rows("100:140").EntireRow.Hidden = True
  [COLOR="Red"]plg[/COLOR].Protect '*si besoin est.
  MsgBox " Tirage effectué avec succès ! "
End Sub[/B][/COLOR]
ROGER2327
#4383

Samedi 21 Haha 138 (Zimzoum de Bosse-de-Nage, ST)
5 Brumaire An CCXIX
2010-W43-2T16:45:57Z
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2021 macro pour faire un tirage au sort
Réponses
4
Affichages
224
marco22
M
J
  • Question
XL 2013 tirage au sort petanque
Réponses
13
Affichages
3 K
jpg17
J
Mapat
  • Question
XL 2019 Correspondance après tirage au sort
Réponses
2
Affichages
659
Mapat
Mapat
S
  • Question
XL 2016 Tirage au sort parmi une liste sans doublons
Réponses
1
Affichages
4 K
job75
job75
Francoise_nord
  • Question
XL 2013 Tirage au sort Équipe avec conditions
Réponses
0
Affichages
2 K
Francoise_nord
Francoise_nord
N
  • Question
XL 2019 Tirage au sort sujet examen sans remise
2
Réponses
19
Affichages
3 K
nanie
N
J
  • Question
XL 2016 Besoin d'aide tirage au sort sans doublons
Réponses
3
Affichages
1 K
Dranreb
Dranreb
H
  • Question
XL 2013 Double tirage au sort : éviter les doublons
Réponses
2
Affichages
1 K
Hrouxel974
H
Fredox
  • Question
XL 2019 [Résolu] VBA - UserForm + SpinButton --> ignorer les lignes masquées
2
Réponses
15
Affichages
1 K
job75
job75
C
  • Résolu(e)
XL 2010 Tirage au sort d'équipes avec conditions en VBA
2 3
Réponses
40
Affichages
7 K
Pounet95
P

Membres actuellement en ligne

1 membres et 73 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 493
Messages
2 088 956
Membres
103 990
dernier inscrit
lamiadebz