XL 2013 archiver plusieurs ligne en même temps

R

Ray97

XLDnaute Nouveau
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
 
Trier par date Trier par votes
K

Kamy

XLDnaute Nouveau
Robert à dit:
Bonjour Kamy,

Je me joins à la foule en délire qui hurle : le fichier, le fichier !...
Cliquez pour agrandir...
Bonjour, j'utilise le même code vba du formulaire inclus dans votre pièce jointe, seulement je souhaite que la ligne copiée depuis source OS soit collé en valeur vers OD.
VB: 
Private OS As Worksheet 'déclare la variable OS (Onglet Source)

Private OD As Worksheet 'déclare la variable OD (Onglet Destination)

Private TV As Variant 'déclare la variable TV (Tableau des Valeurs)

 

Private Sub UserForm_Initialize() 'à l'initialisation de l'UserForm

Set OS = Worksheets("feuil1") 'définit l'onglet source OS

Set OD = Worksheets("Archives") 'définit l'onglet destination OD

TV = Range("A1").CurrentRegion 'définit le tableau des valeurs TV

With Me.ListBox1 'prend en compte la Listbox1

    .ColumnCount = 10 'définit le nombre de colonnes de la Listbox1 (max 10)

End With 'fin de la prise en compte de la ListBox1

End Sub

 

Private Sub TextBox1_Change()

Dim I As Integer 'déclare la variable I (Incrément)

Dim J As Integer 'déclare la variable J (incrément)

Dim K As Integer 'déclare la variable K (incrément)

Dim L As Integer 'déclare la variable L (incrément)

Dim TL() As Variant 'déclare la variable TL(tableau des Lignes)

 

Me.ListBox1.Clear 'vide la ListBox1

If Me.TextBox1.Value = "" Then Exit Sub 'si la TextBox1 est effacée, sort de la procédure

K = 1 'initialise la variable K

For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la quatrième)

    For J = 1 To 10 'boucle 2 : sur les 6 premières colonnes J du tableau des valeurs TV

        If InStr(1, TV(I, J), Me.TextBox1.Value, vbTextCompare) <> 0 Then 'condition : si le texte de la TextBox1 est contenu dans la donnée ligne I colonne J de TV

            ReDim Preserve TL(1 To 10, 1 To K) 'redimensionne le tableau des lignes TL (6 lignes, K colonnes)

            For L = 1 To 10 'boucle 3 : sur les 6 premières colonnes L du tableau des valeurs TV

                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=> tranposition)

            Next L 'prochaine colonne de la boucle 3

            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)

            Exit For 'sort de la boucle 2

        End If 'fin de la condition

    Next J 'prochaine colonne de la boucle 2

Next I 'prochaine ligne de la boucle 1

If K > 1 Then Me.ListBox1.Column = TL 'si K est supérieure à 1, alimente la listBox1 avec le tableau des lignes TL

End Sub

 

Private Sub ListBox1_Click()

Dim F As String 'déclare la variable F (cell1)[MOD]

Dim C As String 'déclare la variable C (cell2)[MOD]

Dim D As String 'déclare la variable D (cell3)[MOD]

Dim N As String 'déclare la variable N (cell4)[MOD]

Dim PL As Range 'déclare la variable PL (cell5)

Dim PLV As Long 'déclare la variable PLV (Première Ligne Vide)

 

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran

Set PL = OS.Range("A1") 'initialise la plage PL

For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)

    F = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]

    C = Me.ListBox1.Column(0, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]

    D = Me.ListBox1.Column(7, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]

    N = Me.ListBox1.Column(8, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]

    If TV(I, 2) = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) Then

        '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, OS.Cells(I, 1).Resize(1, 35), Application.Union(PL, OS.Cells(I, 1).Resize(1, 35)))

    End If 'fin de la condition

Next I 'prochaine ligne de la boucle

'si "Non" au message, sort de la procédure

If MsgBox("blabla, vbYesNo, "ATTENTION") = vbNo Then Exit Sub

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, 2) 'copie la plage PL et la colle dans la cellule ligne PLV colonne 1 de l'onget OD

OD.Cells(PLV, 1).Resize(PL.Rows.Count, 1).Value = Now 'renvoie la date dans la colonne A

PL.Range("F1").ClearContents 'efface cellule plage PL [MOD]

OD.Activate 'active l'onglet OD (ligne à supprimer éventuellement)

Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran

 

Unload Me

 

''Box confirmation et retour page [MOD]

MsgBox "blabla?"

With ActiveWorkbook

.Sheets("feuil1").Activate

PL.Range("F1").Cells.Select

End With

''''fin box confirmation [MOD]

 

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re,

Non testé :
VB: 
Private Sub ListBox1_Click()
Dim F As String 'déclare la variable F (cell1)[MOD]
Dim C As String 'déclare la variable C (cell2)[MOD]
Dim D As String 'déclare la variable D (cell3)[MOD]
Dim N As String 'déclare la variable N (cell4)[MOD]
Dim PL As Range 'déclare la variable PL (cell5)
Dim PLV As Long 'déclare la variable PLV (Première Ligne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set PL = OS.Range("A1") 'initialise la plage PL
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    F = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]
    C = Me.ListBox1.Column(0, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]
    D = Me.ListBox1.Column(7, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]
    N = Me.ListBox1.Column(8, Me.ListBox1.ListIndex) 'déclare la COL de PL à afficher Box confirmation  [MOD]
    If TV(I, 2) = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) Then
        '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, OS.Cells(I, 1).Resize(1, 35), Application.Union(PL, OS.Cells(I, 1).Resize(1, 35)))
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
'si "Non" au message, sort de la procédure
If MsgBox("blabla", vbYesNo, "ATTENTION") = vbNo Then Exit Sub
PLV = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la première ligne vide PLV de la colonne A de l'ongelt OD

'******************************************************************************************************************
PL.Copy 'copie la plage PL
OD.Cells(PLV, 2).PasteSpecial (xlPasteValues) 'colle les valeurs dans la cellule ligne PLV colonne 1 de l'onget OD
'******************************************************************************************************************

OD.Cells(PLV, 1).Resize(PL.Rows.Count, 1).Value = Date 'renvoie la date dans la colonne A
PL.Range("F1").ClearContents 'efface cellule plage PL [MOD]
OD.Activate 'active l'onglet OD (ligne à supprimer éventuellement)
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
Unload Me
''Box confirmation et retour page [MOD]
MsgBox "blabla?"
With ActiveWorkbook
    .Sheets("feuil1").Activate
    PL.Range("F1").Cells.Select
End With
''''fin box confirmation [MOD]
End Sub
 
Vote positif 0 Vote négatif
K

Kamy

XLDnaute Nouveau
Bonjour, c'est encore moi.

Initialement la formule du userform copie l'emsenbles des lignes ayant la même réfèrence que la cellule en A si j'ai bien compris, dans mon cas je souhterais que seul la ligne sélectionnée dans listbox soit copiée. J'ai tâtonné encore une fois pour comprendre quoi modifier mais je but. Pourriez vous svp m'apporter encore une fois votre aide svp. Merci d'avance
 
Vote positif 0 Vote négatif

Discussions similaires

Z
  • Résolu(e)
XL 2019 Problème liens Hypertexte
2
Réponses
16
Affichages
1 K
Zapinet
Z
VBA_dev_Anne_Marie
  • Résolu(e)
XL 2019 SQL ADODB avec plusieurs lignes en input
2
Réponses
17
Affichages
1 K
fanch55
fanch55
P
  • Résolu(e)
Microsoft 365 En fonction d'une condition, copier plusieurs cellules particulières d'un coup
Réponses
4
Affichages
918
PCharlier
P
A
  • Résolu(e)
XL 2016 Macro consolidation plusieurs fichiers en 1 seul
Réponses
8
Affichages
2 K
Alan28
A
Y
  • Question
XL 2016 Macro calcul complexe
Réponses
8
Affichages
1 K
youpi457032
Y
T
  • Question
Trier les informations d'une liste déroulante
Réponses
3
Affichages
2 K
Toubabou
T
V
  • Question
Problème correspondance Valeur et Textbo d'un userform
Réponses
2
Affichages
2 K
VOILLOT
V
jeuno
  • Question
Exécuter la même macro sur plusieurs feuilles en auto
Réponses
9
Affichages
1 K
jeuno
jeuno
jeje77
  • Question
(De)Proteger plusieurs feuilles sélectionnées en même temps (Résolu)
Réponses
7
Affichages
4 K
jeje77
jeje77
M
  • Question
Déplacer une ligne dans une autre feuille
Réponses
2
Affichages
2 K
MaximeS
M

Membres actuellement en ligne

2 membres et 44 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 645
Messages
2 111 536
Membres
111 185
dernier inscrit
Laurent.