Microsoft 365 Archivage Ligne Tableau sous condition

[eric72]

Bonjour à tous,
Nouveau petit souci!!!
J'ai un Tableau "BDDEffectif" avec une colonne date de Sortie, j'aimerais que lorsque la date est renseignée, ça coupe la ligne et la copie dans mon autre tableau dans archives "TbArchives", j'ai trouvé pas mal d'exemples mais je n'arrive pas à l'adapter.
Quelqu'un peut-il m'aider.
Merci d'avance à tous les cracks d'Excel
Eric

 

[Robert]

Bonsoir Éric, bonsoir le forum,

Essaie avec l'événementielle Change ci-dessous à placer dans le composant Feuil1 (Base Effectifs). L'action se fera chaque fois que tu taperas une date dans la colonne Date Sortie :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TS As ListObject 'déclare la variale TS (Tableau structuré Source)
Dim OD As Worksheet 'déclare la variale OD (Onglet Destination)
Dim TD As ListObject 'déclare la variale TD (Tableau structuré Destination)
Dim R As Range 'déclare la variale R (Recherche)
Dim LI As Integer 'déclare la variale LI (LIgne)

Set TS = Me.ListObjects(1) 'définit le tableau structuré source TS
Set OD = Worksheets("Archives") 'définit l'onglet destination OD
Set TD = OD.ListObjects(1) 'définit le tableau structuré destination TD
'si le changement a lieu ailleurs que dans la colonne 38 du tableau structuré source
If Application.Intersect(Target, TS.DataBodyRange.Columns(38)) Is Nothing Then Exit Sub
Set R = TD.DataBodyRange.Columns(1).Find("") 'définit la recherche R (recherche du vide dans la première colonne du tableau structuré destination)
If R Is Nothing Then 'si ocune occurrence trouvée
    TD.ListRows.Add 'ajoute une ligne au tableau structuré destination
    LI = TD.ListRows.Count 'définit la ligne LI
Else 'sinon (au moins une occurrence trouvée)
    LI = R.Row - TD.HeaderRowRange.Row 'définit la ligne LI (ligne de la première occurrence trouvée - la ligne des en-têtes))
End If 'fin de la condition
TS.DataBodyRange.Rows(Target.Row - TS.HeaderRowRange.Row).Copy TD.DataBodyRange(LI, 1) 'copy la ligne de la date et la colle dans LI
TS.DataBodyRange.Rows(Target.Row - TS.HeaderRowRange.Row).Delete 'supprime la ligne de la date
End Sub

 

[eric72]

Bonjour Robert,
Tout d'abord merci pour la réponse, toutefois je préfèrerais mettre le code dans un module car, la date de sortie est inscrite lors de la modification des infos du salarié et du coup ca beug car il veut modifier une ligne qui n'existe plus dans la base!!!
J'espère être assez clair dans mes explications.
L'avantage du module c'est que je pourrais l'attribuer au bouton quitter de l'userform.
Merci beaucoup
Eric

 

[Robert]

Re,

Je pensais ça aussi mais ta requête était :

j'aimerais que lorsque la date est renseignée, ça coupe la ligne et la copie dans mon autre tableau dans archives

Je regarde ça...

[Édition]
Ça donne :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As ListObject 'déclare la variale TS (Tableau structuré Source)
Dim OD As Worksheet 'déclare la variale OD (Onglet Destination)
Dim TD As ListObject 'déclare la variale TD (Tableau structuré Destination)
Dim PL As Range 'déclare la variable PL (Plage)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim R As Range 'déclare la variale R (Recherche)
Dim LI As Integer 'déclare la variale LI (LIgne)

Set OS = Worksheets("Base Effectifs") 'définit l'onglet source OS
Set TS = OS.ListObjects(1) 'définit le tableau structuré source TS
Set OD = Worksheets("Archives") 'définit l'onglet destination OD
Set TD = OD.ListObjects(1) 'définit le tableau structuré destination TD
Set PL = OS.Range("A1") 'initialise la plage PL
For I = 1 To TS.ListRows.Count 'boucle sur toutes les lignes I du tableau structuré TS
    If TS.DataBodyRange(I, 38) <> "" Then 'condition : si la cellule ligne I colonne 38 des données de TS n'est pa vide
        'définit la plage PL (si PL ne contient qu'une seule cellue, la ligne, sinon l'union de PL et de la ligne)
        Set PL = IIf(PL.Cells.Count = 1, TS.DataBodyRange.Rows(I), Application.Union(PL, TS.DataBodyRange.Rows(I)))
        NL = NL + 1 'incrémente NL
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
TD.Resize TD.Range.Resize(TD.ListRows.Count + NL, TD.ListColumns.Count) 'redimensionne le tableau structuré source TS
Set R = TD.DataBodyRange.Columns(1).Find("") 'définit la recherche R (recherche du vide dans la première colonne du tableau structuré destination)
If R Is Nothing Then 'si ocune occurrence trouvée
    TD.ListRows.Add 'ajoute une ligne au tableau structuré destination
    LI = TD.ListRows.Count 'définit la ligne LI
Else 'sinon (au moins une occurrence trouvée)
    LI = R.Row - TD.HeaderRowRange.Row 'définit la ligne LI (ligne de la première occurrence trouvée - la ligne des en-têtes))
End If 'fin de la condition
PL.Copy TD.DataBodyRange(LI, 1) 'copy la plage PL et la colle dans LI
PL.Delete 'supprime la plage PL
End Sub

 

[eric72]

Bonjour Robert,
oups par contre ca coupe toutes les lignes de la base et recopie toutes les lignes dans archives!!!
Trop efficace...

 

[Robert]

Re,

Oups suivi de trop efficace je ne saisis pas bien. Ça va comme ça ou pas ?

 

[eric72]

Non en fait ca transfère l'ensemble des données et pas uniquement celles ou il y a une date de sortie, mon tableau BDDEffectif est donc vide
Merci Robert

 

[Robert]

Re,

Chez moi ça fonctionne !?... Ton fichier en pièce jointe. Lance la procédure Macro1 du module Module1...
Je n'ai pas mis de bouton car je ne savais pas où le mettre...

 

[eric72]

Bonjour Robert,

En effet ça fonctionne mais dès que je remplis la liste avec plus de données (voir le fichier), ca colle toutes les lignes!!! Mystère...
Je ne comprends pas pourquoi.
Désolé et merci beaucoup
Eric

 

[eric72]

Re Robert,
J'ai trouvé il suffisait de modifier:
If TS.DataBodyRange(I, 38) <> 0 Then avec un 0 au lieu de ""
Merci 1000 fois pour le temps passé et votre dévouement.
Sujet résolu.
Bonne journée
Eric