Bonjour,
avec le post : aide pour macro, insertion de cellules auto
tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction
de leur emploi, repos,...
je te rappelle le code :
Private Sub Cmd_Distribuer_Click()
Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer
Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100,
2) As String
Dim Fleuriste As Long, Boulanger As Long
Dim x As Long, y As Long, sh As Worksheet
Dim ResJour As String
ResJour = "lundi"
Set Plage = Sheets("Personnes").Range("A1",
Sheets("Personnes").Range("A65536").End(xlUp))
For Each c In Plage
If c.Offset(0, 1) = "Boulanger" Then
TabBoul(Boulanger, 0) = c.Value
TabBoul(Boulanger, 1) = c.Offset(0, 1).Value
TabBoul(Boulanger, 2) =
Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Boulanger = Boulanger + 1
ElseIf c.Offset(0, 1) = "Fleuriste" Then
TabFleur(Fleuriste, 0) = c.Value
TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value
TabFleur(Fleuriste, 2) =
Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Fleuriste = Fleuriste + 1
End If
Next c
' Traitement du lundi
Range("C5:C17").ClearContents
Range("G5:G17").ClearContents
Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17"))
If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"),
0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
'Traitement des autres jours
For Each sh In Sheets
If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then
With sh
.Range("C5:C17").ClearContents
.Range("G5:G17").ClearContents
.Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(.Range("A5:A17"), .Range("E5:E17"),
.Range("I5:I17"))
If IsNumeric(Application.Match(c,
Sheets("Personnes").Range("J:J"), 0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> LCase(sh.Name) And _
TabprovF(IndF, 0) <> ResJour Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
ResJour = LCase(sh.Name)
End With
End If
Next sh
End Sub
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Jour = Application.Match("Repos", _
Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0,
7)), 0)
Jour = Application.Index(Sheets("Personnes").Range("C1:H1"),
1, Jour)
If LCase(Jour) = LCase(sh.Name) Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
J'ai un petit souci avec les repos :
Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte
que ça en gere plus?
ex : si pour tutu, j'ai un repos lundi et mardi
et bien il ne sera affecté que sur la feuille lundi et non pas mardi
--
Merci de votre aide
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Daniel
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide
Bonjour.
Remplace la macro :
Private Sub Cmd_Repos_Click()
par :
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour, Personne
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Personne = c.Row - 1
Jour = Application.Match(LCase(sh.Name), _
Sheets("Personnes").Range("C1:H1"), 0) + 2
If Application.Index(Plage.Resize(, 8), Personne, Jour) _
= "Repos" Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
Cordialement.
Daniel
"squeepy" <squeepy@discussions.microsoft.com> a écrit dans le message de
news: 5BD9EAC1-47BC-4E33-8962-1BBA065DADAD@microsoft.com...
Bonjour,
avec le post : aide pour macro, insertion de cellules auto
tu m'avais bien aidé pour insérer des personnes dans un tableau en
fonction
de leur emploi, repos,...
je te rappelle le code :
Private Sub Cmd_Distribuer_Click()
Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer
Dim Plage As Range, c As Range, TabBoul(100, 2) As String,
TabFleur(100,
2) As String
Dim Fleuriste As Long, Boulanger As Long
Dim x As Long, y As Long, sh As Worksheet
Dim ResJour As String
ResJour = "lundi"
Set Plage = Sheets("Personnes").Range("A1",
Sheets("Personnes").Range("A65536").End(xlUp))
For Each c In Plage
If c.Offset(0, 1) = "Boulanger" Then
TabBoul(Boulanger, 0) = c.Value
TabBoul(Boulanger, 1) = c.Offset(0, 1).Value
TabBoul(Boulanger, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Boulanger = Boulanger + 1
ElseIf c.Offset(0, 1) = "Fleuriste" Then
TabFleur(Fleuriste, 0) = c.Value
TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value
TabFleur(Fleuriste, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Fleuriste = Fleuriste + 1
End If
Next c
' Traitement du lundi
Range("C5:C17").ClearContents
Range("G5:G17").ClearContents
Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17"))
If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"),
0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
'Traitement des autres jours
For Each sh In Sheets
If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then
With sh
.Range("C5:C17").ClearContents
.Range("G5:G17").ClearContents
.Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(.Range("A5:A17"), .Range("E5:E17"),
.Range("I5:I17"))
If IsNumeric(Application.Match(c,
Sheets("Personnes").Range("J:J"), 0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> LCase(sh.Name) And _
TabprovF(IndF, 0) <> ResJour Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
ResJour = LCase(sh.Name)
End With
End If
Next sh
End Sub
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Jour = Application.Match("Repos", _
Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0,
7)), 0)
Jour =
Application.Index(Sheets("Personnes").Range("C1:H1"),
1, Jour)
If LCase(Jour) = LCase(sh.Name) Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
J'ai un petit souci avec les repos :
Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en
sorte
que ça en gere plus?
ex : si pour tutu, j'ai un repos lundi et mardi
et bien il ne sera affecté que sur la feuille lundi et non pas mardi
--
Merci de votre aide
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide
squeepy
merci, merci, merci
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide
merci, merci, merci
Bonjour.
Remplace la macro :
Private Sub Cmd_Repos_Click()
par :
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour, Personne
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Personne = c.Row - 1
Jour = Application.Match(LCase(sh.Name), _
Sheets("Personnes").Range("C1:H1"), 0) + 2
If Application.Index(Plage.Resize(, 8), Personne, Jour) _
= "Repos" Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
Cordialement.
Daniel
"squeepy" <squeepy@discussions.microsoft.com> a écrit dans le message de
news: 5BD9EAC1-47BC-4E33-8962-1BBA065DADAD@microsoft.com...
Bonjour,
avec le post : aide pour macro, insertion de cellules auto
tu m'avais bien aidé pour insérer des personnes dans un tableau en
fonction
de leur emploi, repos,...
je te rappelle le code :
Private Sub Cmd_Distribuer_Click()
Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer
Dim Plage As Range, c As Range, TabBoul(100, 2) As String,
TabFleur(100,
2) As String
Dim Fleuriste As Long, Boulanger As Long
Dim x As Long, y As Long, sh As Worksheet
Dim ResJour As String
ResJour = "lundi"
Set Plage = Sheets("Personnes").Range("A1",
Sheets("Personnes").Range("A65536").End(xlUp))
For Each c In Plage
If c.Offset(0, 1) = "Boulanger" Then
TabBoul(Boulanger, 0) = c.Value
TabBoul(Boulanger, 1) = c.Offset(0, 1).Value
TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Boulanger = Boulanger + 1
ElseIf c.Offset(0, 1) = "Fleuriste" Then
TabFleur(Fleuriste, 0) = c.Value
TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value
TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Fleuriste = Fleuriste + 1
End If
Next c
' Traitement du lundi
Range("C5:C17").ClearContents
Range("G5:G17").ClearContents
Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17"))
If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"),
0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
'Traitement des autres jours
For Each sh In Sheets
If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then
With sh
.Range("C5:C17").ClearContents
.Range("G5:G17").ClearContents
.Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(.Range("A5:A17"), .Range("E5:E17"),
.Range("I5:I17"))
If IsNumeric(Application.Match(c,
Sheets("Personnes").Range("J:J"), 0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> LCase(sh.Name) And _
TabprovF(IndF, 0) <> ResJour Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
ResJour = LCase(sh.Name)
End With
End If
Next sh
End Sub
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Jour = Application.Match("Repos", _
Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0,
7)), 0)
Jour =
Application.Index(Sheets("Personnes").Range("C1:H1"),
1, Jour)
If LCase(Jour) = LCase(sh.Name) Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
J'ai un petit souci avec les repos :
Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en
sorte
que ça en gere plus?
ex : si pour tutu, j'ai un repos lundi et mardi
et bien il ne sera affecté que sur la feuille lundi et non pas mardi
--
Merci de votre aide
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide
squeepy
encore merci une derniere question : avec le programme, quand il n'y a pas assez de monde, ca boucle à l'infini et c'est normal je pense. Est ce qu'il n'y a pas moyen de laisser les champs à blanc si il n'y a pas assez de monde et arreter la boucle? -- Merci de votre aide
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide
encore merci
une derniere question :
avec le programme, quand il n'y a pas assez de monde, ca boucle à l'infini
et c'est normal je pense.
Est ce qu'il n'y a pas moyen de laisser les champs à blanc si il n'y a pas
assez de monde et arreter la boucle?
--
Merci de votre aide
Bonjour.
Remplace la macro :
Private Sub Cmd_Repos_Click()
par :
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour, Personne
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Personne = c.Row - 1
Jour = Application.Match(LCase(sh.Name), _
Sheets("Personnes").Range("C1:H1"), 0) + 2
If Application.Index(Plage.Resize(, 8), Personne, Jour) _
= "Repos" Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
Cordialement.
Daniel
"squeepy" <squeepy@discussions.microsoft.com> a écrit dans le message de
news: 5BD9EAC1-47BC-4E33-8962-1BBA065DADAD@microsoft.com...
Bonjour,
avec le post : aide pour macro, insertion de cellules auto
tu m'avais bien aidé pour insérer des personnes dans un tableau en
fonction
de leur emploi, repos,...
je te rappelle le code :
Private Sub Cmd_Distribuer_Click()
Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer
Dim Plage As Range, c As Range, TabBoul(100, 2) As String,
TabFleur(100,
2) As String
Dim Fleuriste As Long, Boulanger As Long
Dim x As Long, y As Long, sh As Worksheet
Dim ResJour As String
ResJour = "lundi"
Set Plage = Sheets("Personnes").Range("A1",
Sheets("Personnes").Range("A65536").End(xlUp))
For Each c In Plage
If c.Offset(0, 1) = "Boulanger" Then
TabBoul(Boulanger, 0) = c.Value
TabBoul(Boulanger, 1) = c.Offset(0, 1).Value
TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Boulanger = Boulanger + 1
ElseIf c.Offset(0, 1) = "Fleuriste" Then
TabFleur(Fleuriste, 0) = c.Value
TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value
TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _
Application.Match("Repos",
Sheets("Personnes").Range(c.Offset(0,
2), c.Offset(0, 7)), 0))
Fleuriste = Fleuriste + 1
End If
Next c
' Traitement du lundi
Range("C5:C17").ClearContents
Range("G5:G17").ClearContents
Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17"))
If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"),
0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
'Traitement des autres jours
For Each sh In Sheets
If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then
With sh
.Range("C5:C17").ClearContents
.Range("G5:G17").ClearContents
.Range("K5:K17").ClearContents
TabprovF = TabFleur
TabprovB = TabBoul
Randomize
For Each c In Union(.Range("A5:A17"), .Range("E5:E17"),
.Range("I5:I17"))
If IsNumeric(Application.Match(c,
Sheets("Personnes").Range("J:J"), 0)) Then
Do While c.Offset(0, 2) = ""
IndF = Int(Fleuriste * Rnd)
If TabprovF(IndF, 2) <> LCase(sh.Name) And _
TabprovF(IndF, 0) <> ResJour Then
c.Offset(0, 2) = TabprovF(IndF, 0)
End If
Loop
TabprovF(IndF, 0) = ""
ElseIf IsNumeric(Application.Match(c,
Sheets("Personnes").Range("K:K"), 0)) Then
Do While c.Offset(0, 2) = ""
IndB = Int(Fleuriste * Rnd)
If TabprovB(IndB, 2) <> "lundi" Then
c.Offset(0, 2) = TabprovB(IndB, 0)
End If
Loop
TabprovB(IndB, 0) = ""
End If
Next c
ResJour = LCase(sh.Name)
End With
End If
Next sh
End Sub
Private Sub Cmd_Repos_Click()
Dim c As Range, Plage As Range, sh As Worksheet
Dim Ctr As Integer, Jour
Set Plage = Sheets("Personnes").Range("A2", _
Sheets("Personnes").Range("A65536").End(xlUp))
For Each sh In Sheets
If sh.Name <> "Personnes" Then
sh.Range("B19:B2000").ClearContents
For Each c In Plage
Jour = Application.Match("Repos", _
Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0,
7)), 0)
Jour =
Application.Index(Sheets("Personnes").Range("C1:H1"),
1, Jour)
If LCase(Jour) = LCase(sh.Name) Then
sh.Range("B19").Offset(Ctr, 0) = c.Value
Ctr = Ctr + 1
End If
Next c
End If
Ctr = 0
Next sh
End Sub
J'ai un petit souci avec les repos :
Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en
sorte
que ça en gere plus?
ex : si pour tutu, j'ai un repos lundi et mardi
et bien il ne sera affecté que sur la feuille lundi et non pas mardi
--
Merci de votre aide
encore merci une derniere question : avec le programme, quand il n'y a pas assez de monde, ca boucle à l'infini et c'est normal je pense. Est ce qu'il n'y a pas moyen de laisser les champs à blanc si il n'y a pas assez de monde et arreter la boucle? -- Merci de votre aide
Bonjour. Remplace la macro : Private Sub Cmd_Repos_Click() par :
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour, Personne Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Personne = c.Row - 1 Jour = Application.Match(LCase(sh.Name), _ Sheets("Personnes").Range("C1:H1"), 0) + 2 If Application.Index(Plage.Resize(, 8), Personne, Jour) _ = "Repos" Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
Cordialement. Daniel "squeepy" a écrit dans le message de news:
Bonjour, avec le post : aide pour macro, insertion de cellules auto tu m'avais bien aidé pour insérer des personnes dans un tableau en fonction de leur emploi, repos,... je te rappelle le code : Private Sub Cmd_Distribuer_Click() Dim TabprovB, TabprovF, IndB As Integer, IndF As Integer Dim Plage As Range, c As Range, TabBoul(100, 2) As String, TabFleur(100, 2) As String Dim Fleuriste As Long, Boulanger As Long Dim x As Long, y As Long, sh As Worksheet Dim ResJour As String ResJour = "lundi" Set Plage = Sheets("Personnes").Range("A1", Sheets("Personnes").Range("A65536").End(xlUp)) For Each c In Plage If c.Offset(0, 1) = "Boulanger" Then TabBoul(Boulanger, 0) = c.Value TabBoul(Boulanger, 1) = c.Offset(0, 1).Value TabBoul(Boulanger, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Boulanger = Boulanger + 1 ElseIf c.Offset(0, 1) = "Fleuriste" Then TabFleur(Fleuriste, 0) = c.Value TabFleur(Fleuriste, 1) = c.Offset(0, 1).Value TabFleur(Fleuriste, 2) > > Application.Index(Sheets("Personnes").Range("C1:H1"), 1, _ Application.Match("Repos", Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0)) Fleuriste = Fleuriste + 1 End If Next c ' Traitement du lundi Range("C5:C17").ClearContents Range("G5:G17").ClearContents Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(Range("A5:A17"), Range("E5:E17"), Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> "lundi" Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c
'Traitement des autres jours For Each sh In Sheets If sh.Name <> "Personnes" And sh.Name <> "Lundi" Then With sh .Range("C5:C17").ClearContents .Range("G5:G17").ClearContents .Range("K5:K17").ClearContents TabprovF = TabFleur TabprovB = TabBoul Randomize For Each c In Union(.Range("A5:A17"), .Range("E5:E17"), .Range("I5:I17")) If IsNumeric(Application.Match(c, Sheets("Personnes").Range("J:J"), 0)) Then Do While c.Offset(0, 2) = "" IndF = Int(Fleuriste * Rnd) If TabprovF(IndF, 2) <> LCase(sh.Name) And _ TabprovF(IndF, 0) <> ResJour Then c.Offset(0, 2) = TabprovF(IndF, 0) End If Loop TabprovF(IndF, 0) = "" ElseIf IsNumeric(Application.Match(c, Sheets("Personnes").Range("K:K"), 0)) Then Do While c.Offset(0, 2) = "" IndB = Int(Fleuriste * Rnd) If TabprovB(IndB, 2) <> "lundi" Then c.Offset(0, 2) = TabprovB(IndB, 0) End If Loop TabprovB(IndB, 0) = "" End If Next c ResJour = LCase(sh.Name) End With End If Next sh End Sub
Private Sub Cmd_Repos_Click() Dim c As Range, Plage As Range, sh As Worksheet Dim Ctr As Integer, Jour Set Plage = Sheets("Personnes").Range("A2", _ Sheets("Personnes").Range("A65536").End(xlUp)) For Each sh In Sheets If sh.Name <> "Personnes" Then sh.Range("B19:B2000").ClearContents For Each c In Plage Jour = Application.Match("Repos", _ Sheets("Personnes").Range(c.Offset(0, 2), c.Offset(0, 7)), 0) Jour = Application.Index(Sheets("Personnes").Range("C1:H1"), 1, Jour) If LCase(Jour) = LCase(sh.Name) Then sh.Range("B19").Offset(Ctr, 0) = c.Value Ctr = Ctr + 1 End If Next c End If Ctr = 0 Next sh End Sub
J'ai un petit souci avec les repos : Pour le repos, ca ne gere qu'une journée par semaine, peut on faire en sorte que ça en gere plus? ex : si pour tutu, j'ai un repos lundi et mardi et bien il ne sera affecté que sur la feuille lundi et non pas mardi -- Merci de votre aide