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
 

Pièces jointes

  • GestionDeStock.xlsx
    25.2 KB · Affichages: 6
Solution
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...

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
 

Pièces jointes

  • GestionDeStock_V2.xlsx
    25.6 KB · Affichages: 5

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+
 

Pièces jointes

  • GestionDeStock(1).xlsm
    38.6 KB · Affichages: 6

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
 

Pièces jointes

  • GestionDeStock(2).xlsm
    39.3 KB · Affichages: 9

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:

Discussions similaires