Filtre Avancé-VBA

Dureux · 17 Janvier 2018

Bonjour,

Je reviens vers vous avec le problème suivant :
Mon filtre avancé fonctionne en ce basant sur les numéros des feuilles en Annexe et arrive donc à fonctionner, afin de me rapporter les donner de tout les échéanciers dans un tableau de relance. Selon le critères réglé="Non". Mais voilà lorsque je déclenche la Macro les informations de relance tel que les numéros, les commentaire ect... ( Les 4 dernières colonnes du tableau ) , qui sont des données qui ne sont pas transférer par la macro et qui sont donc "définitivent" s'effacent.

Y a t-il un moyen de faire en sorte que ces données ne puissent pas s'effacer?

Voici le Code de la Macro :

Sub FILTREAVANCE()
Application.ScreenUpdating = False
Dim cellule As Variant, plage As Range, i As Integer, Nbfeuilles As Integer
Set plage = Feuil7.Range("A1", Feuil7.Range("G" & Rows.Count).End(xlUp)).Rows
Nbfeuilles = Feuil8.Range("K16").CurrentRegion.Count
For i = 1 To 1
Sheets("RELANCE 1").Select
Sheets(i).Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets _
("ANNEXE").Range("A1:A2"), CopyToRange:=plage, Unique _
:=False
Next
For i = 2 To Nbfeuilles
cellule = Feuil7.Range("A" & Rows.Count).End(xlUp).Rows(2).Address
Feuil7.Range("A1:K1").Copy Feuil7.Range(cellule)
Sheets(i).Range("A5").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets _
("ANNEXE").Range("A1:A2"), CopyToRange:=Range(cellule & ":G60"), Unique _
:=False
Range(cellule).EntireRow.Delete
Next
Application.ScreenUpdating = True
End Sub

Je vous joins le Fichier .
Je débute tout juste en VBA et visiblement on n'apprend pas à coder en une journée xD... Enfin du coup c'est Clavus qui m'a apporté son aide et m'a créé ce codage et je l'en remercie.

Merci d'avance de votre aide

job75 · 17 Janvier 2018

Bonjour Dureux,

C'est cette instruction qui vous posait problème :

Code:

Range(cellule).EntireRow.Delete

En effet elle supprime la ligne entière donc aussi les cellules des colonnes H I J K.

La macro de Calvus n'est pas mauvaise mais ceci est plus cohérent :

Code:

Sub FILTREAVANCE()
Application.ScreenUpdating = False
Dim critere As Range, w As Worksheet, titres As Range
Set critere = Sheets("ANNEXE").[A1:A2]
Application.ScreenUpdating = False
With Feuil7.[A:G]  'feuille RELANCE 1
    .Rows(2).Resize(.Rows.Count - 1).ClearContents 'RAZ
    For Each w In Worksheets
        If w.Name Like "ECHEANCIER*" Then
            Set titres = .Cells(.Rows.Count, 1).End(xlUp)(2).Resize(, .Columns.Count)
            .Rows(1).Copy titres
            w.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, critere, titres
            titres.Delete xlUp
        End If
    Next
End With
End Sub

Cela dit si l'on ajoute ou supprime des "Non" dans les feuilles "ECHEANCIER" il est évident que les données en colonnes H I J K ne correspondront plus aux factures auxquelles elles appartenaient.

Il faudra les replacer sur les bonnes lignes, voire les supprimer.

C'est compliqué, je verrai cela quand j'aurai le temps.

A+

job75 · 17 Janvier 2018

Re,

Voyez cette macro :

Code:

Sub FILTREAVANCE()
Dim critere As Range, ncol%, mem, w As Worksheet, titres As Range, a(), i&, j As Variant, k%
Application.ScreenUpdating = False
Set critere = Sheets("ANNEXE").[A1:A2]
With Feuil7.[A:G]  'feuille RELANCE 1
    ncol = .Columns.Count
    mem = .CurrentRegion.Resize(, ncol + 4) 'mémorise A:K
    .Rows(2).Resize(.Rows.Count - 1, ncol + 4).Delete xlUp 'RAZ
    For Each w In Worksheets
        If w.Name Like "ECHEANCIER*" Then
            Set titres = .Cells(.Rows.Count, 1).End(xlUp)(2).Resize(, ncol)
            .Rows(1).Copy titres
            w.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, critere, titres
            titres.Delete xlUp
        End If
    Next w
    '---restitution des valeurs en colonnes H I J K---
    If .CurrentRegion.Rows.Count > 1 Then
        ReDim a(1 To .CurrentRegion.Rows.Count - 1, 1 To 5) 'tableau, plus rapide
        For i = 2 To UBound(mem)
            j = Application.Match(mem(i, 3), .Columns(3), 0) 'recherche le n° de facturee
            If IsNumeric(j) Then
                j = j - 1
                If a(j, 5) = "" Then 'évite les doublons
                    For k = 1 To 4
                        a(j, k) = mem(i, ncol + k)
                    Next k
                    a(j, 5) = 1 'repérage
                End If
            End If
        Next i
        .Cells(2, ncol + 1).Resize(UBound(a), 4) = a 'restitution
    End If
    .CurrentRegion.Borders.Weight = xlThin 'bordures
    With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Le tableau de la feuille "RELANCE 1" est mémorisé (mem) avant d'être supprimé (RAZ).

Ce qui permet à la fin de restituer les valeurs des colonnes H I J K au bon endroit.

Normalement il ne devrait pas y avoir de doublon de numéros de factures en colonne C.

En fait sur votre fichier il y en a un : M504 en cellules C4 et C7.

Dans ce cas la restitution laisse vides les colonnes H I J K du doublon (H7:K7).

A+

Dureux · 18 Janvier 2018

Merci beaucoup job75 pour tes codages, cela fonctionne comme je le souhaite, je garde les deux et voit en avançant dans la création de mon Fichier celui qui conviendrait le mieux. En tout cas merci de ton aide c'est très gentils de m'accorder ce temps là.

job75 · 18 Janvier 2018

Bonjour Dureux,

Le 1er code est insuffisant si l'on veut récupérer les entrées (manuelles) en colonnes H I J K.

Et peut-être faudra-t-il même compliquer encore un peu.

En effet il faut savoir que les Application.Match du 2ème code prennent du temps.

Pour aller vite sur un grand tableau on utilisera très classiquement l'objet Dictionary :

Code:

Sub FILTREAVANCE()
Dim critere As Range, ncol%, mem, w As Worksheet, titres As Range, num_facture, d As Object, i&, a(), j&, k%
Application.ScreenUpdating = False
Set critere = Sheets("ANNEXE").[A1:A2]
With Feuil7.[A:G]  'feuille RELANCE 1
    ncol = .Columns.Count
    mem = .CurrentRegion.Resize(, ncol + 4) 'mémorise A:K
    .Rows(2).Resize(.Rows.Count - 1, ncol + 4).Delete xlUp 'RAZ
    For Each w In Worksheets
        If w.Name Like "ECHEANCIER*" Then
            Set titres = .Cells(.Rows.Count, 1).End(xlUp)(2).Resize(, ncol)
            .Rows(1).Copy titres
            w.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, critere, titres
            titres.Delete xlUp
        End If
    Next w
    '---restitution des valeurs en colonnes H I J K---
    If .CurrentRegion.Rows.Count > 1 Then
        num_facture = .Cells(2, 3).Resize(.CurrentRegion.Rows.Count - 1, 2) 'tableau avec au moins 2 éléments
        Set d = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(num_facture)
            If Not d.exists(num_facture(i, 1)) Then d(num_facture(i, 1)) = i 'repérage de la ligne
        Next i
        ReDim a(1 To UBound(num_facture), 1 To 4) 'tableau, plus rapide
        For i = 2 To UBound(mem)
            j = d(mem(i, 3)) 'recherche le n° de facture dans le dictionnaire
            If j Then
                For k = 1 To 4
                    a(j, k) = mem(i, ncol + k)
                Next k
                d.Remove mem(i, 3) 'évite les doublons dans mem
            End If
        Next i
        .Cells(2, ncol + 1).Resize(UBound(a), 4) = a 'restitution
    End If
    .CurrentRegion.Borders.Weight = xlThin 'bordures
    With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

A+

Filtre Avancé-VBA

Dureux

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Dureux

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires

Filtre Avancé-VBA

Dureux

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Dureux

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency