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

 

[piga25]

Bonjour vgendron, le forum

Merci
Je regarde et essaies d'assimiler les codes

 

[piga25]

Bonjour,

cela semble bien fonctionner. Merci

Pour voir si je comprends bien, dans le code suivant :

Sub RecordSeizureWeek(NumSemaine As Integer)
Dim TabNom() 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
    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
    NumLigne = NumSemaine + 3 'correspondance avec les feuilles Noms...
    .Range("C8").Resize(UBound(TabNom) - 1, 40).ClearContents
    .Range("C7").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom) - 1, 40).ClearContents
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

En particulier pour la ligne :
.Cells(NumLigne, j + 40) = TabDay(i + 4, j)

si je mets : .Cells(NumLigne, j + 40) = TabDay(i *2 +2, j)
cela me permet bien d'avoir la liste de nom variable, c'est a dire que je peux en ajouter.
la variable "i" étant la liste de nom, donc pour trouver le bon emplacement dans afternoon il faut bien compter deux fois la variable "i" et ajouter 2 lignes (2 lignes séparant les tableaux morning et afternoon).

 

[vgendron]

Salut
effectivement, le raisonnement est bon..
c'est bien ce que j'avais mis AVANT.. mais.. je ne sais pas pourquoi. j'avais un décalage...sans doute parce que AVANT je ne prenais pas la ligne d'entete... et comme j'ai pas creusé..j'ai laissé comme ca :-D

 

[piga25]

Bonjour

J'ai trouvé comment faire pour avoir une liste de nom variable automatiquement

Sub ImportWeek(NumSemaine As Integer)
Dim TabNom() As Variant
Dim TabDay() As Variant

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

'on commence par effacer Morning et Afternoon
    .Range("C7").Offset(1, 0).Resize(UBound(TabNom) - 1, 40).ClearContents
    .Range("C7").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom) - 1, 40).ClearContents
  
'on set TabDay (permet de garder les lignes d'entete SUN, MON....
    TabDay = .Range("B7").Resize(UBound(TabNom) * 2 + 1, 41).Value
    '.Range("B7").Resize(UBound(TabNom) * 2 + 1, 41).Select 'pour voir ce qui vient d'etre mis dans le tableau
   
    NumLigne = NumSemaine + 3 'ligne de destination dans les feuilles "NomX"
End With

'on Remplit le tableau à partir des feuilles
For i = LBound(TabNom, 1) + 1 To UBound(TabNom, 1)
'Z = i + 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 + UBound(TabNom, 1) + 1, j) = .Cells(NumLigne, j + 40)
            Next j
        End With
    End If
Next i
'on colle le résultat dans la feuille
With WsS
    .Range("B7").Resize(UBound(TabDay, 1), UBound(TabDay, 2)) = TabDay
End With
End Sub



Sub RecordSeizureWeek(NumSemaine As Integer)
Dim TabNom() 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
    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
    NumLigne = NumSemaine + 3 'correspondance avec les feuilles Noms...
    .Range("C8").Resize(UBound(TabNom) - 1, 40).ClearContents
    .Range("C7").Offset(UBound(TabNom) + 2).Resize(UBound(TabNom) - 1, 40).ClearContents
End With

For i = LBound(TabNom, 1) + 1 To UBound(TabNom, 1)
'Z = i + 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 + UBound(TabNom, 1) + 1, j)
                '.Cells(NumLigne, j + 40) = TabDay(i + 12, j)
            Next j
        End With
    End If
Next i
End Sub

Je continue mes recherches maintenant pour insérer automatiquement une ligne supplémentaire dans chaque tableau Morning et Afternoon

 

[piga25]

Bonjour,

J'ai bien réussis à adapter un code pour insérer une ligne dans chaque tableau, mais je coince pour intégrer le texte de l'imputbox
voici les codes que j'ai

Sub test()
Nom
Morning
Afternoon
End Sub

Sub Morning()
Dim vnom As String, vrech As Range, derlign As Long
'nom du tableau
vnom = "Morning"
'je recherche le nom dans la colonne A
Set vrech = Columns(1).Find(vnom)
'si je trouve le nom alors
If Not vrech Is Nothing Then
'je récupère le n° de ligne de la fin du tableau correspondant
derlign = Range("B" & vrech.Row).End(xlDown).Row + 1
'Tableau Morning
'faire une nouvelle ligne
Range("A" & derlign).EntireRow.Insert Shift:=xlDown
'copier la ligne du dessus
Range("A" & derlign).Offset(-1, 0).EntireRow.Copy Cells(derlign, 1)
On Error Resume Next
'effacer le contenu de la nouvelle ligne mais garder la forme
Range("A" & derlign).EntireRow.SpecialCells(xlCellTypeConstants, 23).ClearContents
End If
End Sub

Sub Afternoon()
Dim vnom As String, vrech As Range, derlign As Long
'nom du tableau
vnom = "Afternoon"
'je recherche le nom dans la colonne A
Set vrech = Columns(1).Find(vnom)
'si je trouve le nom alors
If Not vrech Is Nothing Then
'je récupère le n° de ligne de la fin du tableau correspondant
derlign = Range("B" & vrech.Row).End(xlDown).Row + 1
'Tableau Afternoon
'faire une nouvelle ligne
Range("A" & derlign).EntireRow.Insert Shift:=xlDown
'copier la ligne du dessus
Range("A" & derlign).Offset(-1, 0).EntireRow.Copy Cells(derlign, 1)
On Error Resume Next
'effacer le contenu de la nouvelle ligne mais garder la forme
Range("A" & derlign).EntireRow.SpecialCells(xlCellTypeConstants, 23).ClearContents
End If
End Sub

Sub Nom()
Dim Nom As String, Cpt As Integer
Cpt = 1
Nom = InputBox("Entrer votre NOM :", "Saisie NOM")
Do While Len(Nom) = 0
    Cpt = Cpt + 1
    If Cpt = 4 Then GoTo TropBetePourContinuer
    MsgBox "Cette donnée est obligatoire. Plus que " & 4 - Cpt & " essais."
    Nom = InputBox("Entrer votre NOM :", "Saisie NOM")
Loop
MsgBox "Votre NOM est :" & Nom
Exit Sub
TropBetePourContinuer:
MsgBox "insertion annulée."
End Sub

Comment intégrer le nom renseigné en colonne B à la fin de chaque tableau?
Si aucun nom de renseigner dans l'imputbox, sortir complètement (cad: ne pas insérer de ligne)

 

[vgendron]

Hello
voir ce code

Public NomClient As String
Sub test()
Nom
Morning
Afternoon
End Sub

Sub Morning()
Dim vnom As String, vrech As Range, derlign As Long
'nom du tableau
vnom = "Morning"
'je recherche le nom dans la colonne A
Set vrech = Columns(1).Find(vnom)
'si je trouve le nom alors
If Not vrech Is Nothing Then
    With Sheets("Seizure week")
        'je récupère le n° de ligne de la fin du tableau correspondant
        derlign = .Range("B" & vrech.Row).End(xlDown).Row + 1
        'Tableau Morning
        'faire une nouvelle ligne
        .Range("A" & derlign).EntireRow.Insert Shift:=xlDown
        'copier la ligne du dessus
        .Range("A" & derlign).Offset(-1, 0).EntireRow.Copy .Cells(derlign, 1)
        On Error Resume Next
        'effacer le contenu de la nouvelle ligne mais garder la forme
        .Range("A" & derlign).EntireRow.SpecialCells(xlCellTypeConstants, 23).ClearContents
        .Range("B" & derlign) = NomClient
    End With
End If
End Sub

Sub Afternoon()
Dim vnom As String, vrech As Range, derlign As Long
'nom du tableau
vnom = "Afternoon"
'je recherche le nom dans la colonne A
Set vrech = Columns(1).Find(vnom)
'si je trouve le nom alors
If Not vrech Is Nothing Then
    With Sheets("Seizure week")
        'je récupère le n° de ligne de la fin du tableau correspondant
        derlign = .Range("B" & vrech.Row).End(xlDown).Row + 1
        'Tableau Afternoon
        'faire une nouvelle ligne
        .Range("A" & derlign).EntireRow.Insert Shift:=xlDown
        'copier la ligne du dessus
        .Range("A" & derlign).Offset(-1, 0).EntireRow.Copy .Cells(derlign, 1)
        On Error Resume Next
        'effacer le contenu de la nouvelle ligne mais garder la forme
        .Range("A" & derlign).EntireRow.SpecialCells(xlCellTypeConstants, 23).ClearContents
        .Range("B" & derlign) = NomClient
    End With
End If
End Sub

Sub Nom()
Dim Cpt As Integer
Cpt = 1
NomClient = InputBox("Entrer votre NOM :", "Saisie NOM")

Do While Len(NomClient) = 0
    Cpt = Cpt + 1
    If Cpt = 4 Then GoTo TropBetePourContinuer
    MsgBox "Cette donnée est obligatoire. Plus que " & 4 - Cpt & " essais."
    NomClient = InputBox("Entrer votre NOM :", "Saisie NOM")
Loop
MsgBox "Votre NOM est :" & NomClient
Exit Sub
TropBetePourContinuer:
MsgBox "insertion annulée."
End Sub

1) il faut déclarer le NomClient en public pour qu'il soit connu des deux macro Morning et Afternoon, une fois qu'il a été saisi dans la macro Nom


2) sinon, il peut y avoir une autre solution en utilsant des "Tables" Excel, que tu peux nommer "TabMorning" et "TabAfternooon"
et pas besoin de chercher où elles sont pour leur ajouter une ligne

voir PJ

 

[piga25]

Bonjour Vgendron, le forum

Merci pour ces explications.
J'avais bien pensé faire Morning et Afternoon sous forme de tableau, mais les étiquettes sur la premières lignes me gênent.

J'ai compris cette ligne :
Public NomClient As String

Cela est évident maintenant.

En tout cas un grand merci pour toutes ces explications, comme quoi on peut en apprendre tous les jours et à n'importe quel âge.

Je continue mon projet, j'ouvrirai surement un autre fil pour cela.

 

[piga25]

Re

Je pense dernière question,
Dans le code "Nom", si le nom n'est pas renseigné, on sort de la procédure, mais comment faire pour les lignes ne soient pas ajouter à ce moment là.

Faut-il chercher dans ce sens là:
if NomClient = ""
exit sub

 

[vgendron]

Exactement

Sub test()
NomClient = ""
Nom
If NomClient = "" Then Exit Sub
Morning
Afternoon
End Sub

 

[piga25]

Merci
J'avais fait mais en mettant la commande dans les codes Morning et Afternoon

C'est plus simple comme cela et surtout plus clair.