XL 2016 Macro pour remplissage de tableau suivant dates

karakoman1

XLDnaute Occasionnel
Bonsoir le forum,
J'aurais besoin de l'aide des spécialistes en macro pour m'aider à trouver et à insérer dans une macro existante les quelques lignes qui me permettraient d'inscrire le mot "Tournoi" dans plusieurs lignes de mon tableau en fonction de dates renseignées dans une plage distincte.
Comme un exemple est très certainement plus clair que mes explications, voici un fichier avec le résultat souhaité.
Merci à qui pourra m'aider
Bonne soirée
 

Pièces jointes

  • Classeur1.xlsx
    10.6 KB · Affichages: 36

karakoman1

XLDnaute Occasionnel
Bonsoir Staple1600,
Voici la bête

VB:
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").Select
    Range("l3:n12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Feuil2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("d:d").Select
    Selection.Cut
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("C:C").Delete
    Range("C1").Select


   
   
   
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
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
 

Staple1600

XLDnaute Barbatruc
Re

Testé sur ton fichier exemple
VB:
Sub a()
Dim rng As Range, c As Range, t, tt, i&
Application.ScreenUpdating = False
Set rng = [T17:Y17]
t = Application.Transpose(rng)
[K3].Resize(UBound(t)) = t
Range("B2") = "X": Range("K2") = "X"
Range("B2:B32").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("K2:K6"), Unique:=False
tt = Split([_FilterDataBase].SpecialCells(xlCellTypeVisible).Address(0, 0), ",")
For i = 1 To UBound(tt)
Cells(Range(tt(i)).Row, "C") = "Tournoi"
Cells(Range(tt(i)).Row, "E") = "Tournoi"
Cells(Range(tt(i)).Row, "G") = "Tournoi"
Cells(Range(tt(i)).Row, "I") = "Tournoi"
Next
Range("B2,K2") = ""
ActiveSheet.ShowAllData: Columns("K:K").ClearContents
End Sub
 

karakoman1

XLDnaute Occasionnel
Re,
Merci Staple1600 de bien vouloir m'aider.
Je viens d'essayer ton code dans mon fichier, mais tu utilises dans ta macro des lignes qui sont déjà utilisées dans mon fichier (j'ai des entêtes de colonnes et des données dans les 2 premières lignes) et d'autres tableaux dans ma feuille et du coup, ça plante, Il n'y a pas moyen de faire autrement?
Sinon j'essayerais de voir demain si je peux changer les lignes afin de pouvoir l'adapter.
Merci quand même
Bonne nuit
 

Staple1600

XLDnaute Barbatruc
Re

Comme je l'ai précédemment écrit.
Ma macro a été testé sur ton fichier exemple du message#1
(Et ma macro fonctionne parfaitement sur ce fichier)

Si ce fichier exemple ne ressemble pas à ton fichier original, c'est pas de mon fait mais du tien.:rolleyes:

Il y surement moyen de faire autrement mais à 23h06 il est temps d'aller rejoindre les bras de Morphée.

PS:
Merci quand même

Merci tout court suffirao_O
 

Staple1600

XLDnaute Barbatruc
Re

Le temps de me brosser les dents et d'enfiler mon pyjama en pilou.
Voici une autre façon de faire
VB:
Sub b()
Const y As String = "Tournoi"
Const z As String = vbNullString
Dim c As Range
For Each c In Range("B3:B32")
If Not IsError(Application.Match(c, Range("$T$17:$Y$17"), 0)) Then
Range(Cells(c.Row, "C"), Cells(c.Row, "I")) = Array(y, z, y, z, y, z, y, z)
End If
Next
End Sub
 

Si...

XLDnaute Barbatruc
Bon_ jour

Le temps d'enlever mon pige_moi_ça …

Pour éviter de combler des cellules déjà alimentées, intégrer dans le code* la ligne JoursJ (appel de la macro suivante)

VB:
Sub JoursJ()
  Dim R As Range, l As Long, n As Byte
  For Each R In [T17:X17]
  On Error Resume Next
  l = Application.Match(R, Range([B3], [B6500].End(xlUp))) + 2
  For n = 3 To 9 Step 2: Cells(l, n) = "Tournoi": Next
  Next
End Sub

* si la feuille réceptrice est différente, se prémunir avec un With, ,End With sans oublier les . et peut-être aussi avec un Call !
il est quand même indispensable de savoir où écrire les macros !

Mal réveillé, je n'ai pas étudié le code donné (qui mérite un petit nettoyage) . J'aurais préféré un fichier plus révélateur mais bon … sur ce, je vais peut-être me recouchero_O.
 

karakoman1

XLDnaute Occasionnel
Bonjour Si...
La, c'est parfaitement ce qu'il me fallait et tout ça, sans effacer les données déja présentes dans le tableau.
Merci
Mal réveillé, je n'ai pas étudié le code donné (qui mérite un petit nettoyage)
C'est vrai qu'il mériterait un petit nettoyage, mais ne connaissant pas le VBA, je fais des assemblages de plusieurs petits codes qui bouts à bouts, font ce qu'on leur demande. Le plus important, c'est que ça fonctionne :)
Je suis sûr que mon fichier passé entre tes mains pourrait être divisé par 10 minimum au niveau du nombres de lignes, mais...
Le but, comme dirait notre ami Staple1600 et qui a tout à fait raison, c'est de participer à l'élaboration de son projet au lieu d'attendre qu'il tombe tout cuit.
Au final c'est moi "Pro", mais ca marche
Je vais essayer cette histoire de pyjama en pilou, ça a l'air de donner de bonnes idées :rolleyes:

Ps: Tu n'as toujours pas abandonné?

Bonne journée
 

Discussions similaires