XL 2013 archiver plusieurs ligne en même temps

[Ray97]

Dans ma base de données sur excel ,j'ai une liste avec plusieurs famille qui sont identifiés par leur numero de foyer . Je veux archiver une famille par exemple si j'ai 5 membre d'une seule famille dans la liste ,je veux qu'il soit supprimer dans la première feuille et coller dans une pages d'archives.
J'ai commencé à le faire en m'aidant d'une macro filtre mais je crois que c'est long et je suis bloquée.

Pouvez vous me proposer d' autre idée plus simple ou m'aider sur celui que j'ai commencé.
Merci d'avance
voici le code:
Private Sub continuer_Click()
Dim taille As Integer
taille = WorksheetFunction.CountA(Columns("A:A")) 'Si A est une colonne qui contient des donn?es non vides
If MsgBox("?tes-vous certain(e) de vouloir archiver le foyer de " & list_nom.Value _
& " dans la " & ActiveSheet.Name & " ?", vbYesNoCancel _
, "Demande de confirmation") = vbYes Then
Call filtre1(list_foyer.Value)
' tu s?lectionnes la plage (ici, les colonnes A ? D, limit?es au nombre de ligne remplies)
Range("A4:AJ" & taille).SpcialCells(x1lTypeVisible).Select

'on les copie
Selection.Cut
Sheets("Archives").Select
'Tu s?l?ctionnes le classeur F1 puis la feuille 2 puis la cellule A1
l = ActiveSheet.["A65536"].End(x1Up).Row + 1

I = Sheets("Archives").Range("A65536").End(xlUp).Row

Range("A" & I).Select
ActiveSheet.Paste
ActiveSheet.Cells(l, 1) = Tdate
Else
Unload Me
End If
Call effacer_filtre
Unload Me
End Sub

la procédure filtre1:
Sub filtre1(list_foyer As String)

Rows("3:3").Select
Selection.AutoFilter
ActiveSheet.Range("$A$3:$GM$15").AutoFilter Field:=2, Criteria1:=list_foyer



Merci

 

[Robert]

Bonjour Ray, bonjour le forum,

Et si fournissais un fichier exemple ?!... Je suis sûr que ton problème serait déjà résolu.

 

[Ray97]

Bonjour Robert,
mon fichier est trop volumineux.

 

[Ray97]

j'envoie un autre que j'ai modifié.

 

[Robert]

Re,

En pièce jointe ton fichier modifié avec deux codes différents.
Dans le composant ThisWorkbook le code :

Private Sub Workbook_Open() 'à l'ouverture du classeur
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim L As String 'déclare la variable L (Liste)

Set O = Worksheets("Feuil1") 'définit l'onglet O
TV = Range("A3").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs (en partant de la seconde)
    D(TV(I, 2)) = "" 'alimente le dictionnaire D avec les données de la colonne 2 du tableau des valeurs TV (le foyer)
Next I 'prochaine ligne de la boucle
L = Join(D.keys, ",") 'définit la liste L (joint les éléments du dictionnaire D sans doublon en les séparant par une virgule)
With Range("A1").Validation 'prend en compte la validation de donnée de la cellule A1
    .Delete 'supprime un éventuelle validation de donnée existante
    .Add Type:=xlValidateList, Formula1:=L 'ajoute une validationde donnée ayant L comme liste
End With 'fin de la prise en compte de la cellule A1
End Sub

Permet de générer automatiquement dans la cellule A1 de l'onglet Feuil1 la liste de validation de données des foyers sans doublon.

Puis dans le composant Feuil1(Feuil1), le code :

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PLV As Long 'déclare la variable PLV (Première Ligne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
If Target.Address <> "$A$1" Then Exit Sub 'si le changement a lieu ailleurs qu'en A1, sort de la procédure
If Target = "" Then Exit Sub 'si A1 est effacée, sort de la procédure
'si "Non" au message, sort de la procédure
If MsgBox("Êtes-vous sûr(e) de vouloir archiver le foyer " & Target.Value & " ?", vbYesNo, "ATTENTION") = vbNo Then Exit Sub
Set PL = Range("A1") 'initialise la plage PL
Set OD = Worksheets("archive") 'définit l'onglet destination OD
TV = Range("A3").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 2) = Target.Value Then 'condition : si la donnée ligne I colonne 2 (le foyer) est égale à la valeur de la cellule A1
        'redéfinit la plage PL (la ligne (I+2) si PL ne contient qu'une seule cellule, sinon l'union de la plage PL et de la ligne (I+2))
        Set PL = IIf(PL.Cells.Count = 1, Rows(I + 2), Application.Union(PL, Rows(I + 2)))
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
PLV = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'de'finit la première ligne vide PLV de la colonne A de l'ongelt OD
PL.Copy OD.Cells(PLV, 1) 'copie la plage PL et la colle dans la cellule ligne PLV colonne 1 de l'onget OD
PL.Delete shift:=xlShiftUp 'supprime la plage PL
OD.Activate 'active l'onglet OD (ligne à supprimer éventuellement)
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Permet d'archiver le le foyer choisi dans la liste de la cellule A1.

Dans la cellule A1 de l'onglet Feuil1 choisit un foyer a archiver, valide le message d'alerte... J'espère que ton vrai fichier est structuré exactement de la même manière que l'exemple que tu as envoyé sinon il faudra adapter le code...

 

[Ray97]

Merci,
il y'a pas plus simple car même dans ce fichier sa marche pas j'ai choisi un foyer mais sa fait rien.
Dans mon code j'ai utiliser une macro filtre , je veux sélectionner le résultat le couper et le coller dans la feuille archives.

 

[Robert]

Re,

il y'a pas plus simple car même dans ce fichier sa marche pas j'ai choisi un foyer mais sa fait rien.

Désolé mais j'ai testé avant de t'envoyer, j'ai testé à nouveau avant de poster maintenant et ÇA MARCHE ! Dans A1 de l'onglet Feuil1 j'ai Choisi le foyer F5. Les lignes 6 et 7 de l'onglet Feuil1 on été déplacées dans l'onglet archive...

 

[Ray97]

tu as appuyer quelque chose?

 

[Ray97]

Quand tu as choisi F5, tu as appuyer quelque chose?

 

[Ray97]

Et si je veux archiver en choisissant le nom et qu'il met tous ceux qui appartiennent au même foyer.
merci.

 

[Robert]

Re,

Ben non puisque ça utilise la macro événementielle Change qui agit automatiquement au changement dans l'onglet Feuil1.
Le code pour rappel :

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PLV As Long 'déclare la variable PLV (Première Ligne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
If Target.Address <> "$A$1" Then Exit Sub 'si le changement a lieu ailleurs qu'en A1, sort de la procédure
If Target = "" Then Exit Sub 'si A1 est effacée, sort de la procédure
'si "Non" au message, sort de la procédure
If MsgBox("Êtes-vous sûr(e) de vouloir archiver le foyer " & Target.Value & " ?", vbYesNo, "ATTENTION") = vbNo Then Exit Sub
Set PL = Range("A1") 'initialise la plage PL
Set OD = Worksheets("archive") 'définit l'onglet destination OD
TV = Range("A3").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 2) = Target.Value Then 'condition : si la donnée ligne I colonne 2 (le foyer) est égale à la valeur de la cellule A1
        'redéfinit la plage PL (la ligne (I+2) si PL ne contient qu'une seule cellule, sinon l'union de la plage PL et de la ligne (I+2))
        Set PL = IIf(PL.Cells.Count = 1, Rows(I + 2), Application.Union(PL, Rows(I + 2)))
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
PLV = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'de'finit la première ligne vide PLV de la colonne A de l'ongelt OD
PL.Copy OD.Cells(PLV, 1) 'copie la plage PL et la colle dans la cellule ligne PLV colonne 1 de l'onget OD
PL.Delete shift:=xlShiftUp 'supprime la plage PL
OD.Activate 'active l'onglet OD (ligne à supprimer éventuellement)
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

 

[Robert]

Et si je veux archiver en choisissant le nom et qu'il met tous ceux qui appartiennent au même foyer.
merci.

C'est exactement ce que fait le code ! Relis mon premier post !... Prend le fichier que je t'ai envoyé et teste le avant de dire n'importe quoi....

 

[Ray97]

C bon merci le code a fonctionné il y avait un message qui s'affichait d'erreur quand j'ouvrais le fichier.
Maintenant par exemple si j'ai beaucoup de foyer et je ne connais par leur numéro de foyer , je connais que leur nom je fais comment.

Merci

 

[Robert]

Re,

C bon merci le code a fonctionné il y avait un message qui s'affichait d'erreur quand j'ouvrais le fichier.
• Quel est message d'erreur et sur quelle ligne de code ?

• Une recherche par nom ne sera pas efficace en cas d'homonymie... Que suggères-tu ?
- Faire une recherche au préalable via une UserForm
- double-cliquer dans une cellule
- autre chose (fait une proposition)

 

[Ray97]

le capture1 c'est le message qui s'afficher après ça marchais pas mais c'est bon.

je suggère de faire faire une userform qui appel la liste des nom et prénom puis qui recherche les foyer correspondant.