XL 2013 archiver plusieurs ligne en même temps

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
 

Robert

XLDnaute Barbatruc
Repose en paix
Re,

En pièce jointe la version 2. Clique sur le bouton Archiver de l'onglet Feuil1. Dans la boîte de dialogue, tape le texte à chercher. La recherche se fait uniquement sur les 6 premières colonnes du tableau. Si une cellule de la ligne contient le texte tapé, la ligne entière s'affiche (du moins, les 6 premières colonnes). Clique sur une ligne dans la ListBox1. Message puis archivage...
 

Pièces jointes

  • Ray_ED_v02.xlsm
    29.3 KB · Affichages: 11

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Ray, bonjour le forum

Ce forum d'entraide est général. S'adresser à moi directement risque de te priver de l'aide d'autres éminents membres. En tous cas, pour ma part, c'est ce que je fais. Si un demandeur s'adresse à quelqu'un en particulier je ne réponds pas...
Si tu m'envoies le lien vers ton autre problème j'essaierai d'y jeter un œil si j'ai le temps et les compétences nécessaires pour t'aider.
 
Dernière édition:

Ray97

XLDnaute Nouveau
Voici le lien merci.
Private Sub Menu_Click()
Dim TL(1) As Long

'Application.ScreenUpdating = False
derlig = Range("A" & Rows.Count).End(xlUp).Row
n = 4
Do While n <= derlig
L = Range("U" & n)
If L <> "" Then
LD = n + 1
LF = n + L - 1
'ajout x ligne(s)
Rows(LD & ":" & LF).Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
'recopie infos BCD, LMN, increment K de 1 a x
Range("B" & n & ":D" & n).Copy Range("B" & LD & ":D" & LF)
Range("L" & n & ":M" & n).Copy Range("L" & LD & ":M" & LF)
Application.CutCopyMode = False
NPF = 1
LD = LD - 1
LF = LF
For m = LD To LF
Range("AG" & m) = NPF
NPF = NPF + 1
Next m
n = n + L
derlig = Range("A" & Rows.Count).End(xlUp).Row
Else
n = n + 1
End If
Loop
'Application.Calculation = xlCalculationManual
' je veux incrementer
'.Range("AD" & AJ) = .Range("AD" & AJ - 1).Formula + .Range("AD" & AJ - 1)
'Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
 

Ray97

XLDnaute Nouveau
Bonjour tous le monde,

Voici le lien pour que vous puissiez m'aider.
Merci d'avance
 

Kamy

XLDnaute Nouveau
Re,

En pièce jointe ton fichier modifié et testé. Clique sur le bouton Menu...

Bonjour,

En faisant mes recherches je suis tombé sur votre post, le vba formulaire dans le fichier joint est parfait pour mon besoin ! je me permet de le récupérer pour l'adapter à mon besoin !

Merci pour le partage !

Mais ayant un grand manque de connaissance, je bloque.

Les lignes que je veux copier/coller ont des cellules avec des formules index et equiv ou recherchev, je souhaiterais que le collage de la ligne soit réalisé en collage spécial/valeur, je ne comprend pas comment modifier cette partie.

Auriez-vous svp la possibilité de m'aider à modifier le code ?

En vous remerciant d'avance.
 

Discussions similaires