VBA: Copier des donnees filtrées

BZH56

BZH56

XLDnaute Occasionnel
VBA: Copier des donnees filtrées -resolu

:DBonjour le fil
Débutant en VBA, je cherche a automatiser une recopie de données filtrées sur une autre feuille mais je coince sur les macros car je trouve des exemples avec des lignes , des colonnes mais pas de plages de cellules..
de plus avec mon filtre , ca complique
ci joint un extrait du fichier.
merci pour le coup de pouce.
 

Pièces jointes

  • pb_bzh5.xls
    38 KB · Affichages: 256
  • pb_bzh5.xls
    38 KB · Affichages: 249
  • pb_bzh5.xls
    38 KB · Affichages: 254
Dernière édition:
Trier par date Trier par votes
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Bonjour BZH56,
Cette macro doit faire l'affaire . . .
Bruno
Code: 
Sub macopy()
lig = [B65000].End(3).Row
lig2 = Feuil1.[B65000].End(3).Row + 1
    ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6, Criteria1:="<>"
    lig = [B65000].End(3).Row
    Range("B2:E" & lig).Copy Feuil1.Range("B" & lig2)
    lig2 = [A65000].End(3).Row + 1
    Range("B2:B" & lig).Copy Range("A" & lig2)
     ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6
End Sub
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Bonsoir BZH56, youky(BJ),
Une autre proposition, sans filtre :
Code: 
[COLOR=blue]Sub[/COLOR] Test()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
Z = 0
[COLOR=blue]With[/COLOR] Feuil2
    lig = .Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=blue]ReDim[/COLOR] Tablo(0 [COLOR=blue]To[/COLOR] lig, 1 [COLOR=blue]To[/COLOR] 4)
    [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] lig
        [COLOR=blue]If[/COLOR] .Cells(i, 6) = "NOUVEAU" [COLOR=blue]Then[/COLOR]
            .Cells((.Cells(Rows.Count, "A").End(xlUp).Row) + 1, 1) = .Cells(i, 1)
                [COLOR=blue]For[/COLOR] k = 2 [COLOR=blue]To[/COLOR] 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                [COLOR=blue]Next[/COLOR] k
                Z = Z + 1
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] i
[COLOR=blue]End With[/COLOR]
[COLOR=blue]With[/COLOR] Feuil1
    .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    .Range("B2").Resize([COLOR=blue]UBound[/COLOR](Tablo, 1), 4) = Tablo
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
 

Pièces jointes

  • pb_bzh5(2).zip
    15.7 KB · Affichages: 133
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
Re : VBA: Copier des donnees filtrées

youky(BJ) à dit:
Bonjour BZH56,
Cette macro doit faire l'affaire . . .
Bruno
Code: 
Sub macopy()
lig = [B65000].End(3).Row
lig2 = Feuil1.[B65000].End(3).Row + 1
    ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6, Criteria1:="<>"
    lig = [B65000].End(3).Row
    Range("B2:E" & lig).Copy Feuil1.Range("B" & lig2)
    lig2 = [A65000].End(3).Row + 1
    Range("B2:B" & lig).Copy Range("A" & lig2)
     ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6
End Sub
Cliquez pour agrandir...
merci youky
il reste un bug avec la deuxieme partie du code qui ecrase les donnes précédentes en colonne a en ecrivant a la fin de la zone filtrée et non en fin de la colonne non filtrée

a suivre
 
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
Re : VBA: Copier des donnees filtrées

Efgé à dit:
Bonsoir BZH56, youky(BJ),
Une autre proposition, sans filtre :
Code: 
[COLOR=blue]Sub[/COLOR] Test()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
Z = 0
[COLOR=blue]With[/COLOR] Feuil2
    lig = .Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=blue]ReDim[/COLOR] Tablo(0 [COLOR=blue]To[/COLOR] lig, 1 [COLOR=blue]To[/COLOR] 4)
    [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] lig
        [COLOR=blue]If[/COLOR] .Cells(i, 6) = "NOUVEAU" [COLOR=blue]Then[/COLOR]
            .Cells((.Cells(Rows.Count, "A").End(xlUp).Row) + 1, 1) = .Cells(i, 1)
                [COLOR=blue]For[/COLOR] k = 2 [COLOR=blue]To[/COLOR] 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                [COLOR=blue]Next[/COLOR] k
                Z = Z + 1
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] i
[COLOR=blue]End With[/COLOR]
[COLOR=blue]With[/COLOR] Feuil1
    .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    .Range("B2").Resize([COLOR=blue]UBound[/COLOR](Tablo, 1), 4) = Tablo
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
Cliquez pour agrandir...
bonjour efge
méthode différente mais tjs un pb pour la recopie des numéros de dossier en colonne a
ce sont les n des nvx dossiers filtres en colonne b que je veux rajouter a la fin de la colonne A
merci de ton aide
 
Vote positif 0 Vote négatif
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Bonsoir Efgé, BZH56,
En effet j'apporte une correction . . .
Bruno
Code: 
Sub macopy()
lig = [B65000].End(3).Row
lig2 = Feuil1.[B65000].End(3).Row + 1
lig3 = Range("A65000").End(3).Row + 1
    ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6, Criteria1:="<>"
    lig = [B65000].End(3).Row
    Range("B2:E" & lig).Copy Feuil1.Range("B" & lig2)
    Range("B2:B" & lig).Copy Range("A" & lig3)
    ActiveSheet.Range("$A$1:$F" & lig).AutoFilter Field:=6
End Sub
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Re à tous,
Je ne comprend pas vraiment le problème rencontré.
Une autre version avant d"aller dormir
Code: 
[COLOR=blue]Sub[/COLOR] Test2()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
[COLOR=blue]Dim[/COLOR] Tablo2()
Z = 0
y = 0
[COLOR=blue]With[/COLOR] Feuil2
    lig = .Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=blue]ReDim[/COLOR] Tablo(0 [COLOR=blue]To[/COLOR] lig, 1 [COLOR=blue]To[/COLOR] 4)
    [COLOR=blue]ReDim[/COLOR] Tablo2(y)
    [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] lig
        [COLOR=blue]If[/COLOR] .Cells(i, 6) = "NOUVEAU" [COLOR=blue]Then[/COLOR]
            Tablo2(y) = .Cells(i, 1)
            y = y + 1
            [COLOR=blue]ReDim Preserve[/COLOR] Tablo2(y)
                [COLOR=blue]For[/COLOR] k = 2 [COLOR=blue]To[/COLOR] 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                [COLOR=blue]Next[/COLOR] k
                Z = Z + 1
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] i
    .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize([COLOR=blue]UBound[/COLOR](Tablo2, 1)) = Application.Transpose(Tablo2)
[COLOR=blue]End With[/COLOR]
[COLOR=blue]With[/COLOR] Feuil1
    .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    .Range("B2").Resize([COLOR=blue]UBound[/COLOR](Tablo, 1), 4) = Tablo
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Bon courage à tous
Cordialement

EDIT :
Pour répondre à la demande il faut remplacer
Code: 
Tablo2(y) = .Cells(i, 1)
par
Code: 
Tablo2(y) = .Cells(i, [COLOR=red][B]2[/B][/COLOR])
 
Dernière édition:
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
Re : VBA: Copier des donnees filtrées

:)bonjour efge
je vois que la nuit porte conseil car ta dernière rectif de 12h40 est la bonne
il me reste a comprendre le code pour ces passages par des tableaux intermédiaires avec toutes ces boucles!!!
encore merci a toi
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Re
Il y avait un problème en cas d'absence de nouveau Dossier, donc une nouvelle version.
Je ne prend plus en compte la colonne F qui peut être supprimée ;).
(0.05 seconde pour 2 000 lignes, Excel 2007, Windows Vista, CoreDuo).
Code: 
[COLOR=blue]Sub[/COLOR] Test3()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
[COLOR=blue]Dim[/COLOR] Tablo2()
Z = 0
y = 0
[COLOR=blue]With[/COLOR] Feuil2
    lig = .Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=blue]ReDim[/COLOR] Tablo(0 [COLOR=blue]To[/COLOR] lig, 1 [COLOR=blue]To[/COLOR] 4)
    [COLOR=blue]ReDim[/COLOR] Tablo2(y)
    [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] lig
        [COLOR=blue]If[/COLOR] .Range("A2:A" & lig).Find(.Cells(i, 2), LookAt:=xlWhole) [COLOR=blue]Is Nothing Then[/COLOR]
            Tablo2(y) = .Cells(i, 2)
            y = y + 1
            [COLOR=blue]ReDim Preserve[/COLOR] Tablo2(y)
                [COLOR=blue]For[/COLOR] k = 2 [COLOR=blue]To[/COLOR] 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                [COLOR=blue]Next[/COLOR] k
                Z = Z + 1
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] i
    [COLOR=blue]If UBound[/COLOR](Tablo2, 1) <> 0 [COLOR=blue]Then[/COLOR] .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize([COLOR=blue]UBound[/COLOR](Tablo2, 1)) = Application.Transpose(Tablo2)
[COLOR=blue]End With[/COLOR]
[COLOR=blue]With[/COLOR] Feuil1
    [COLOR=blue]If[/COLOR] .Range("B2") <> "" [COLOR=blue]Then[/COLOR] .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    .Range("B2").Resize([COLOR=blue]UBound[/COLOR](Tablo, 1), 4) = Tablo
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
 
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
VBA: Copier des donnees filtrées-resolu

:D:Dparfait EFGE et impressionnant pour la rapidite.
mais je n aurais jamais 2000 lignes.par contre je souhaite limite ma colonne (a) de stockage des numéros .
aujourd'hui , je les trie dans mon fichier d' origine et je conserve les 500 derniers qui me sont suffisants.
comme je n ai pas encore tout compris dans ton code que j ai déjà adapte au vrai fichier , j oserais te demande ce petit rajout .
ton code avec ces tableaux intermédiaires qui inclut la comparaison va me donner la migraine mais tu a enrichi le forum...
ca a l air simple a l écriture alors encore bravo.:)
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Bonjour BZH56, le fil, le forum,
Il me faudrait quelques précisions:
  • La colonne A est triée après l'importation ?
  • De A ==> Z ?
  • Que ce passe t'il pour les colonnes B à E ?
  • Fau t il les vidées?
Essai de donner un nouvel exemple Avant / Après ;).
Cordialement
 
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
Re : VBA: Copier des donnees filtrées

Merci efge de continuer a t occuper de mon cas...
les précisions que tu demandes
après avoir passe la macro pour rechercher les nouveaux dossiers, effectivement , je vides les colonnes B à E.
Ensuite , comme je ne veux pas garder trop de numéros de dossiers (ils me servent juste a tester ), je les trie en ordre croissant et je conserve les 500 derniers.
@+ sur le fil:cool:
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : VBA: Copier des donnees filtrées

Re
Une proposition faites sous 2007, donc à tester sous 2003...
Code: 
[COLOR=blue]Sub[/COLOR] Test4()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
[COLOR=blue]Dim[/COLOR] Tablo2()
Z = 0
y = 0
[COLOR=blue]With[/COLOR] Feuil2
    lig = .Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=blue]ReDim[/COLOR] Tablo(0 [COLOR=blue]To[/COLOR] lig, 1 [COLOR=blue]To[/COLOR] 4)
    [COLOR=blue]ReDim[/COLOR] Tablo2(y)
    [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] lig
        [COLOR=blue]If[/COLOR] .Range("A2:A" & lig).Find(Cells(i, 2), LookAt:=xlWhole) [COLOR=blue]Is Nothing Then[/COLOR]
            Tablo2(y) = .Cells(i, 2)
            y = y + 1
            [COLOR=blue]ReDim Preserve[/COLOR] Tablo2(y)
                [COLOR=blue]For[/COLOR] k = 2 [COLOR=blue]To[/COLOR] 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                [COLOR=blue]Next[/COLOR] k
                Z = Z + 1
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] i
    [COLOR=blue]If UBound[/COLOR](Tablo2, 1) <> 0 [COLOR=blue]Then[/COLOR] .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize([COLOR=blue]UBound[/COLOR](Tablo2, 1)) = Application.Transpose(Tablo2)
    Lig2 = .Cells(Rows.Count, "A").End(xlUp).Row
    Range("B2:E" & Lig2).ClearContents
    [COLOR=blue]With[/COLOR] .Sort
        .SetRange Range("A2:A" & Lig2)
        .Header = xlNo
        .Orientation = xlTopToBottom
        .Apply
    [COLOR=blue]End With[/COLOR]
[COLOR=blue]If[/COLOR] Lig2 > 500 [COLOR=blue]Then[/COLOR] Rows(2 & " : " & Lig2 - 500).Delete
[COLOR=blue]End With[/COLOR]
[COLOR=blue]With[/COLOR] Feuil1
    [COLOR=blue]If[/COLOR] .Range("B2") <> "" [COLOR=blue]Then[/COLOR] .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    .Range("B2").Resize([COLOR=blue]UBound[/COLOR](Tablo, 1), 4) = Tablo
    .Activate
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement

EDIT
Remplacer If Lig2 > 500 par If Lig2 > 502
 

Pièces jointes

  • pb_bzh5(4).zip
    13.4 KB · Affichages: 129
Dernière édition:
Vote positif 0 Vote négatif
BZH56

BZH56

XLDnaute Occasionnel
Re : VBA: Copier des donnees filtrées

:Dmerci efge
j ai commente ton code , avec une rectif dans le premier comptage qui n'était pas sur la bonne colonne et peux tu vérifier si c est ok car j ai encore une ligne dont je n ai pas encore compris la fonction
Code: 
Sub Test3()
' désactivation de l'ecran
Application.ScreenUpdating = False
'Déclaration de Dimensionnement des tableaux intermediaires et variable de boucles
Dim Tablo()
Dim Tablo2()
Z = 0
y = 0
With Feuil2
'comptage du nombre de numéros de dossier extraits en colonne b
    lig = .Cells(Rows.Count, "B").End(xlUp).Row
'Redimensionnement des tableaux intermédiaires
    ReDim Tablo(0 To lig, 1 To 4)
    ReDim Tablo2(y)
'Comparaison des numéros de dossiers entre colonne A et B
    For i = 2 To lig
        If .Range("A2:A" & lig).Find(.Cells(i, 2), LookAt:=xlWhole) Is Nothing Then
            Tablo2(y) = .Cells(i, 2)
            y = y + 1
  'Stockage du nouveau numero de dossier dans tablo2 avec conservation des données précédentes
            ReDim Preserve Tablo2(y)
  'Stockage du detail des dossiers dans tablo (plusieurs dimensions)
                For k = 2 To 5
                    Tablo(Z, k - 1) = .Cells(i, k)
                Next k
                Z = Z + 1
        End If
    Next i
    
   ' je n'ai pas bien compris l 'utilité de cette étape ci dessous
    If UBound(Tablo2, 1) <> 0 Then .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize(UBound(Tablo2, 1)) = Application.Transpose(Tablo2)
    
    
    'comptage du nombre de numéros de dossier
    Lig2 = .Cells(Rows.Count, "A").End(xlUp).Row
    'effacement de l'extraction colonne B à E
    Range("B2:E" & Lig2).ClearContents
    ' tri des numéros de dossier
         With .Sort
        .SetRange Range("A2:A" & Lig2)
        .Header = xlNo
        .Orientation = xlTopToBottom
        .Apply
      End With
'effacement des numéros de dossiers pour conserver les 40 derniers
If Lig2 > 40 Then Rows(2 & ":" & Lig2 - 40).Delete
End With
With Feuil1
'effacement des données précédentes
    If .Range("B2") <> "" Then .Range("B2:F" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
'copie des nouveaux dossiers
    .Range("B2").Resize(UBound(Tablo, 1), 4) = Tablo
End With
'reactivation de l'ecran
Application.ScreenUpdating = True
End Sub

:):)je suis très satisfait de cette collaboration du fil
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Question code VBA
Réponses
2
Affichages
113
Maxou69
M
M
  • Question
Microsoft 365 VBA copier des données d'un classeur à un autre
Réponses
4
Affichages
176
sylvanu
sylvanu
C
  • Question
Microsoft 365 copier coller en changeant la disposition et plage de donnees variable
Réponses
5
Affichages
449
cg1980
C
VBA_dev_Anne_Marie
  • Résolu(e)
Microsoft 365 Copier les données filtrées
Réponses
3
Affichages
290
Phil69970
Phil69970
P
  • Question
XL 2021 creer une export tableau dynamique via VBA et avec des criteres pre defini
Réponses
1
Affichages
138
pasquetp
P
E
  • Résolu(e)
Microsoft 365 copier coller Resize
2 3 4
Réponses
56
Affichages
1 K
Phil69970
Phil69970
X
  • Question
XL 2016 Souci copier/coller avec un filtre.
2 3 4
Réponses
55
Affichages
3 K
Xender
X
A
  • Question
XL 2019 Filtre avancé + Colonnes spécifiques (VBA)
Réponses
9
Affichages
321
Amilo
A
VBA_dev_Anne_Marie
  • Question
Microsoft 365 VBA: Filtrer et copier les données
Réponses
10
Affichages
712
VBA_dev_Anne_Marie
VBA_dev_Anne_Marie
B
  • Question
Microsoft 365 Filtrer des colonnes multiples
Réponses
1
Affichages
129
WTF
WTF

Membres actuellement en ligne

5 membres et 56 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
312 196
Messages
2 086 098
Membres
103 116
dernier inscrit
kutobi87