XL 2016 Copie ligne sous deux conditions (VBA)

[piga25]

Bonjour,

Cela fait un bon moment que je suis venu et que j'ai utilisé Excel (on oublie vite).
Je me permet de vous solliciter pour ce problème:
Dans le fichier joint, dans l'onglet "Seizure week" je renseigne le tableau semaine par semaine à l'aide de la toupie situé en B3 B4.

j'aimerai à par partir de la feuille "Seizure week" copier les données (Morning et afternoon) de chaque participant (1ère condition) dans leur propre onglet en les inscrivant sur le bon numéro de semaine (2ème condition)
Pour bien faire, il faudrait effectuer cette copie lorsque l'on utilise le bouton toupie, de même lorsque la valeur de la semaine revient en arrière que cela affiche les données déjà sauvegardées dans les feuilles individuelles.

Les tableaux morning et afternoon seront toujours identique. Le seul changement sera le nombre de participants.

Pour les feuilles individuelles, j'ai une préférence pour la feuille Nom1 (plus simple que la feuille Nom2)

J'ai bien essayé à partir d'un code trouvé, mais sans résultat probant.

Cordialement
Piga25

 

[vgendron]

Hello

Un début de code pour enregistrer les datas dans les feuilles

Sub RecordSeizureWeek()
Dim TabNom() As Variant
'Dim TabMorning() As Variant
'Dim TabAfternoon() As Variant
Dim TabDay() As Variant

Set WsS = Worksheets("Seizure week")
With WsS
    FinNom = .Range("B7").End(xlDown).Row
    TabNom = .Range("B8:B" & FinNom).Value
    'MsgBox UBound(TabNom)
'    TabMorning = .Range("B8").Resize(UBound(TabNom), 41).Value
'    TabAfternoon = .Range("B8").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom), 41).Value
  
    TabDay = .Range("B8").Resize(UBound(TabNom) * 2 + 2, 41).Value
    NumSemaine = .Range("B4")
    NumLigne = NumSemaine + 3
End With


For i = LBound(TabNom, 1) To UBound(TabNom, 1)
    If FeuilleExiste(CStr(TabNom(i, 1))) Then
        With Sheets(TabNom(i, 1))
            For j = LBound(TabDay, 2) + 1 To UBound(TabDay, 2)
                .Cells(NumLigne, j) = TabDay(i, j)
                .Cells(NumLigne, j + 40) = TabDay(i + 12, j)
            Next j
        End With
    End If
Next i
End Sub

Fonctionne avec le modèle de feuille "Nom1"

 

[piga25]

Bonjour vgendron

Merci.
Cela fonctionne bien avec le model de feuille "Nom1"
J'ai affecté la macro au bouton toupie.

J'ai modifié :
NumLigne = NumSemaine + 3
en NumLigne = NumSemaine + 2
de cette façon cela se met bien dans la bonne semaine

Il me reste à faire l'inverse, récupérer les données si semaine déjà saisie. de cette façon, lorsque l'on passe à la semaine suivante les tableau Morning et Afternoon seront vierge. Par contre si on revient en arrière, cela récupérera les données déjà saisies, donc modification possible.

Il faut aussi que je regarde comment faire pour pouvoir ajouter des onglets lorsque ceux-ci ne sont pas présent.

 

[vgendron]

NumLigne = NumSemaine + 3
en NumLigne = NumSemaine + 2

tu as du changer la feuille Nom entre temps. parce que avec la 1ere version de fichier que tu as posté. la semaine 27 va bien à la semaine 27 ligne30
ou alors. il y a quelque chose que je n'ai pas vu..?

reste à faire l'inverse

j'ai pas encore commencé, mais l'idée serait
1) compter le nombre de feuilles "Nomx" ==> ce qui donne le nombre de lignes du tableau à récupérer (j'aime pas le redim preserve d'un tableau...)
2) pour chaque feuille, on récupère la ligne de la semaine
3) on colle dans Seizure Week

pour pouvoir ajouter des onglets

un petit coup d'enregistreur de macro va vite te donner le code

 

[vgendron]

bah en fait, c'est plus simple que prévu..
voir code ci dessous pour "importer" la semaine affichée

Sub ImportWeek()

Dim TabNom() As Variant

Dim TabDay() As Variant

Set WsS = Worksheets("Seizure week")
With WsS
    FinNom = .Range("B7").End(xlDown).Row
    TabNom = .Range("B8:B" & FinNom).Value
    'MsgBox UBound(TabNom)
    .Range("C8").Resize(UBound(TabNom), 40).ClearContents
    .Range("C8").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom), 40).ClearContents
   
    TabDay = .Range("B8").Resize(UBound(TabNom) * 2 + 2, 41).Value
    NumSemaine = .Range("B4")
    NumLigne = NumSemaine + 3
   
End With

'on Remplit le tableau à partir des feuilles
For i = LBound(TabNom, 1) To UBound(TabNom, 1)
    If FeuilleExiste(CStr(TabNom(i, 1))) Then
        With Sheets(TabNom(i, 1))
            For j = LBound(TabDay, 2) + 1 To UBound(TabDay, 2)
                TabDay(i, j) = .Cells(NumLigne, j)
                TabDay(i + 12, j) = .Cells(NumLigne, j + 40)
            Next j
        End With
    End If
Next i
With WsS
    .Range("B8").Resize(UBound(TabNom) * 2 + 2, 41) = TabDay
End With

End Sub

 

[piga25]

Re

Pour l'ajout de feuille j'ai fait cela

Sub ajout_feuilles()
    Dim nom As String, c As Range
    For Each c In Range("liste")
        nom = c.Value
        If nom <> "" Then
            Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = nom
            Range("tab_3").Copy ActiveSheet.Range("A1")
        End If
    Next c
End Sub

Il faut que je trouve une ligne qui me permet de ne pas créer la feuille si celle-ci existe déjà

 

[vgendron]

si elle existe déjà. tu as la fonction "FeuilleExiste" déjà dispo dans ton code

essaie ceci

Sub ajout_feuilles()
    Set WsS = Worksheets("Seizure week")
With WsS
    FinNom = .Range("B7").End(xlDown).Row
    TabNom = .Range("B8:B" & FinNom).Value
End With

For i = LBound(TabNom, 1) To UBound(TabNom, 1)
    If Not FeuilleExiste(CStr(TabNom(i, 1))) Then
        Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = CStr(TabNom(i, 1))
        Range("tab_3").Copy ActiveSheet.Range("A1")
    End If
Next i
End Sub

 

[piga25]

Re
Bien pour la récupération des données
Merci

 

[piga25]

re
Petit soucis
Dans Sub ImportWeek() un bug à la ligne : If FeuilleExiste(CStr(TabNom(i, 1))) Then

 

[piga25]

Re
Autant pour moi, j'avais effacé le code de la function "FeuilleExiste"

 

[piga25]

Re
Un grand merci vgendron
Je teste en situation réelle et je vous dis ce qu'il en est.
Merci

 

[piga25]

Bonjour,
Après contrôle j'ai toujours un soucis avec les inscriptions :
- Les données ne s'efface pas lorsque je clique sur la toupie pour avancer d'une semaine.
- Les données afternoon sont décalées d'une ligne je pense
- Par contre lorsque l'on clique sur la toupie pour diminuer d'une semaine tout est décalé.

J'ai essayé de modifier le code pour avoir un nombre de noms variables, mais cela ne semble pas fonctionner correctement.

Nota: pas bien compris les lignes :
TabDay = .Range("B8").Resize(UBound(TabNom) * 2 + 2, 41).Value
et
For j = LBound(TabDay, 2) + 1 To UBound(TabDay, 2)

 

[vgendron]

Bonjour

il me semblait avoir commenté le code.. as tu bien repris les dernières macro.??
regarde celui ci

Sub RecordSeizureWeek()
Dim TabNom() As Variant
'Dim TabMorning() As Variant
'Dim TabAfternoon() As Variant
Dim TabDay() As Variant

Set WsS = Worksheets("Seizure week")
With WsS 'dans la feuille "Seizure week"
    FinNom = .Range("B7").End(xlDown).Row 'dernière ligne du nom (en partant de B7 vers le bas (jusqu'à la première ligne vide -en fin de morning)
    TabNom = .Range("B7:B" & FinNom).Value 'on met la liste des noms dans un tablo VBA
    'MsgBox UBound(TabNom)
'    TabMorning = .Range("B8").Resize(UBound(TabNom), 41).Value
'    TabAfternoon = .Range("B8").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom), 41).Value
    TabDay = .Range("B7").Resize(UBound(TabNom) * 2 + 1, 41).Value 'on met tout le tableau (Morning + Afternoon) dans un tablo VBA
    '.Range("B7").Resize(UBound(TabNom) * 2 + 1, 41).Select 'pour voir ce qui vient d'etre mis dans le tableau
    NumSemaine = .Range("B4") 'récupère le Numéro de la semaine
    NumLigne = NumSemaine + 3 'correspondance avec les feuilles Noms...
End With


For i = LBound(TabNom, 1) + 1 To UBound(TabNom, 1)
    If FeuilleExiste(CStr(TabNom(i, 1))) Then
        With Sheets(TabNom(i, 1))
            For j = LBound(TabDay, 2) + 1 To UBound(TabDay, 2)
                .Cells(NumLigne, j) = TabDay(i, j)
                .Cells(NumLigne, j + 40) = TabDay(i + 4, j)
                '.Cells(NumLigne, j + 40) = TabDay(i + 12, j)
            Next j
        End With
    End If
Next i
End Sub

Pour ta toupie.. tu as affecté la macro précédente pour un plus ET un moins..==> aucune chance de récupérer les infos

 

[vgendron]

j'ai modifié
1) le spin bouton en Spin bouton ActiveX, de sorte qu'on puisse avoir son code en VBA SpinUp et spinDown
chacun appele la macro qui va bien
2) j'ai modifié les macro
pour qu'elles aillent chercher les bonnes semaines, (ou qu'elle enregistre sur la bonne ligne)
pour qu'elles effacent la feuille seizure week quand on fait up après enregistrement

3) ATTENTION !!
si tu fais QUE du up à partir de 20 (par exemple), jusqu'à 30, les semaines seront bien enregistrées dans les noms...
ensuite. tu redescends jusqu'à 20.. les semaines seront bien récupéréées à partir des noms...
mais si tu descends toujours jusqu'à 10: comme il n'y a rien d'enregistré, il n'y aura rien (normal), mais la. si te remontes à 20...
la macro enregistre ce qui est à l'écran.. donc.. la ligne 20 sera effacée

==> le problème vient du fait qu'on ne fait un IMPORT uniquement à la descente...
est ce vraiment le résultat attendu?

 

[vgendron]

nouvelle correction
tu peux maintenant passer d'une semaine à l'autre dans les deux sens

==>quand tu changes de semaine, ce qui était à l'écran est sauvegardé dans les feuilles "NOmx"
et la nouvelle semaine est chargée
==> tu peux donc modifier