Résolu Autres Macro pour extraction sans doublons selon date

R@chid

XLDnaute Barbatruc
Bonjour @ tous,
Chers amis, Chers contributeurs,
je deviens très gentille lorsque j'ai besoin d'un code VBA puisque moi et le VBA faisons 17,15 :D;)
Comme vous allez vois sur le fichier ci-joint, j'aurai besoin d'une macro qui me fait l'extraction sans doublons des produits sur une base de données en tenant compte de la date saisie dans une cellule.
Comme on disait toujours un fichier exemple vaut mieux qu'un long discours.


Cordialement
 
Ce fil a été résolu! Aller à la solution…

Fichiers joints

R@chid

XLDnaute Barbatruc
Bonjour WTF,
merci de ton retour, je maitrise très bien les TCDs et les formules mais je préfère rester sur les macros VBA.

Cordialement
 

job75

XLDnaute Barbatruc
Bonjour R@chid, WTF,

Pourquoi mettre les "Bons de livraison" sous B5 ? Je les aurais vu plutôt en colonne E, 1ère colonne du tableau des résultats.

A+
 

R@chid

XLDnaute Barbatruc
Bonjour cher Job75,
Bonjour R@chid, WTF,

Pourquoi mettre les "Bons de livraison" sous B5 ? Je les aurais vu plutôt en colonne E, 1ère colonne du tableau des résultats.

A+
question pertinente, c'est parce que je ne veux pas classer par BL et PRODUITS, je les ai mis sous B5, juste pour avoir une idée sur tous les BL du client sélectionné pour une période donnée.
Voir sous les yeux tous les BL, et trier les produits sans doublons.

Cordialement
 

Fichiers joints

R@chid

XLDnaute Barbatruc
Re,
si vous avez d'autres idées je suis preneur, on peut si vous voulez bien ajouter une autre colonne où l'on va mentionner les BL où il figure chaque produit, mais quand on aura des dizaines de BL de chaque client par mois la colonne prendra toute une page.

Cordialement
 

job75

XLDnaute Barbatruc
Utilise le fichier joint et cette macro :
VB:
Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro pour mettre à jour le tableau
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim clien$, mois As Byte, an%, tablo, resu(), d As Object, i&, x$, n&, lig&
client = [B2]
mois = Month([B3]): an = Year([B3])
tablo = Sheets("MOUV_SORTIES").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 4)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
    If tablo(i, 2) = client And Month(tablo(i, 6)) = mois And Year(tablo(i, 6)) = an Then
        x = tablo(i, 3) & Chr(1) & tablo(i, 5) 'en cas de prix différents pour un même produit
        If Not d.exists(x) Then
            n = n + 1
            d(x) = n 'mémorise la ligne
            resu(n, 1) = tablo(i, 1)
            resu(n, 2) = tablo(i, 3)
            resu(n, 4) = tablo(i, 5)
        End If
        lig = d(x)
        resu(lig, 3) = resu(lig, 3) + tablo(i, 4)
    End If
Next
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [E3]
    If n Then
        .Resize(n, 4) = resu
        .Resize(n, 4).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).Delete xlUp 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
J'ai tenu compte du fait que pour un même produit il pourrait se faire (?) qu'il y ait des prix différents dans le mois.

La macro est très rapide car elle utilise des tableaux VBA et le Dictionary.

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Il est vrai que pour un même produit il peut y avoir plusieurs bons de livraison.

Alors il vaut mieux les lister séparément comme dans ce fichier (2) avec les bons de livraison sous B5 :
VB:
Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro pour mettre à jour le tableau
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim clien$, mois As Byte, an%, tablo, resu(), d1 As Object, d2 As Object, i&, x$, n&, lig&
client = [B2]
mois = Month([B3]): an = Year([B3])
tablo = Sheets("MOUV_SORTIES").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 4)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
    If tablo(i, 2) = client And Month(tablo(i, 6)) = mois And Year(tablo(i, 6)) = an Then
        d1(tablo(i, 1)) = ""
        x = tablo(i, 3) & Chr(1) & tablo(i, 5) 'en cas de prix différents pour un même produit
        If Not d2.exists(x) Then
            n = n + 1
            d2(x) = n 'mémorise la ligne
            resu(n, 1) = tablo(i, 3)
            resu(n, 3) = tablo(i, 5)
        End If
        lig = d2(x)
        resu(lig, 2) = resu(lig, 2) + tablo(i, 4)
    End If
Next
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [B6]
    If d1.Count Then .Resize(d1.Count) = Application.Transpose(d1.keys) 'Transpose est limitée à 65536 lignes
    .Offset(d1.Count).Resize(Rows.Count - d1.Count - .Row + 1).Delete xlUp 'RAZ en dessous
End With
With [E3]
    If n Then
        .Resize(n, 3) = resu
        .Resize(n, 3).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).Delete xlUp 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
 
Ce message a été identifié comme étant une solution!

Fichiers joints

R@chid

XLDnaute Barbatruc
Bonsoir cher Job75,
merci pour les deux propositions, j'ai beaucoup aimé le fait de penser aussi à un produit vendu par des prix différents aux même client, si l'on peut colorier les produits avec ce cas là avec une couleur différente puisque la macro me supprime la MFC.

Mille mercis cher Job75
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour R@chid,

Où as-tu vu que la macro supprime la MFC ?

Si tu veux construire une MFC en colonne E de la feuille EXTRACTION du fichier (2) il faut l'appliquer à la colonne E entière.

A+
 

R@chid

XLDnaute Barbatruc
Bonjour cher Job75,
oui j'applique la MFC juste sur une plage de cellule, mais t'as raison, quand je l'ai appliquée sur les colonnes entières ça a bien fonctionné sans souci.

Merci mon ami

@ bientôt pour d'autres questions.
 

R@chid

XLDnaute Barbatruc
Bonsoir CISCO, Job75 et WTF,

joyeuse année 2020 chers amis.


Au plaisir de vous croiser sur les fils.
 

job75

XLDnaute Barbatruc
Bonjour CISCO, R@chid,

Merci et très bonne année 2020 à vous deux.

A+
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas