karakoman1
XLDnaute Occasionnel
Bonjour le forum,
J'aimerais si c'est possible, pouvoir importer dans un tableau comportant des dates, des noms de personnes provenant d'une liste, tout en évitant de mettre ces personnes les jours ou ils sont indisponibles.
Un exemple concret vaut mieux que mes explications. (Voir fichier)
Voici la macro dans laquelle il faudrait pouvoir l'intégrer.
	
	
	
	
	
		
Merci d'avance à qui pourra m'aider
	
		
			
		
		
	
				
			J'aimerais si c'est possible, pouvoir importer dans un tableau comportant des dates, des noms de personnes provenant d'une liste, tout en évitant de mettre ces personnes les jours ou ils sont indisponibles.
Un exemple concret vaut mieux que mes explications. (Voir fichier)
Voici la macro dans laquelle il faudrait pouvoir l'intégrer.
		Code:
	
	
	Sub Test_V2()
'Variables
Dim t As Variant, i&, lgDeb&, nCopy&, item$
'valeurs dans l'array
Application.ScreenUpdating = False
                  'Copier coller la liste des joueurs et le nombre de fois sur la feuille 4
    Sheets("Tableau").Range("N3:N12").Copy Destination:=Sheets("Feuil2").Range("A1")
Sheets("Tableau").Range("L3:L12").Copy Destination:=Sheets("Feuil2").Range("B1")
Sheets("Feuil2").Select
                ' Faire 4 colonnes de 30 noms sur la feuil2
t = Range("a1").CurrentRegion
lgDeb = 1 'début ligne
'boucle
For i = 1 To UBound(t, 1)
     item = t(i, 2): nCopy = t(i, 1) - 1
     If nCopy > -1 Then
     Range("d" & lgDeb & ":d" & (lgDeb + nCopy)).Value = item 'recopie en colonne d
     lgDeb = lgDeb + nCopy + 1 'incrément
     Range("D1").Select
    Range(Selection, Selection.End(xlDown)).Select
     End If
Next
Dim TSrc(), RngCbl As Range, TCbl(), LSrc As Long, CSrc As Long, LCbl As Long, CCbl As Long
TSrc = Selection.Value
On Error Resume Next
Set RngCbl = Range("f1:i30")
If Err Then Exit Sub
On Error GoTo 0
ReDim TCbl(1 To RngCbl.Rows.Count, 1 To RngCbl.Columns.Count)
CCbl = 1
For CSrc = 1 To UBound(TSrc, 2)
    For LSrc = 1 To UBound(TSrc, 1): LCbl = LCbl + 1
       If LCbl > UBound(TCbl, 1) Then
          LCbl = 1: CCbl = CCbl + 1: If CCbl > UBound(TCbl, 2) Then Exit For
          End If
       TCbl(LCbl, CCbl) = TSrc(LSrc, CSrc): Next LSrc, CSrc
RngCbl.Value = TCbl
                'Importer les 4 plages de 30 noms dans le tableau
Range("F1").Select
Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Tableau").Select
    Range("c3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Select
    Range("G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Tableau").Select
    Range("e3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Select
    Range("H1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Tableau").Select
    Range("g3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Select
    Range("I1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Tableau").Select
    Range("i3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
     Sheets("Feuil2").Select
        Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Tableau").Select
    Range("B2").Select
   'Appel des macros "mixer_joueur" et les executer 5 fois chacune
    For i = 1 To 5
Application.Run "Module1.Mixer_joueur_1"
Application.Run "Module1.Mixer_joueur_2"
Application.Run "Module1.Mixer_joueur_3"
Application.Run "Module1.Mixer_joueur_4"
Next
  Application.ScreenUpdating = True
End Sub
	Pièces jointes
			
				Dernière édition: