Gerer Base de Données

KTM

KTM

XLDnaute Impliqué
Salut chers Tous
Mon probleme du jour est le suivant
Je travaille sur une base de données dans laquelle en face de chaque état de stock d'un produit ( RUPTURE,STOCK DORMANT,SURSTOCK) on doit lister toutes les structures pouvant apporter un appuis .
Par exemple dans mon fichier joint :
Le produit "a" est
-En dormance à AB et DH
-En Rupture à DX,RT,TF
-En surstock à CD,DGK
Donc on doit pouvoir en Face de chaque STOCK DORMANT et SURSTOCK lister (DX,RT,TF) c'est à dire les Structures ayant connu RUPTURE
et en face de Chaque RUPTURE lister (AB,CD,DH,DGK) c'est à dire les structures avec STOCK DORMANT ou SURSTOCK.
Avec une Base de donnée restreinte comme dans ce test c'est Facile , mais avec la réelle Base de Donnée c'est un véritable calvaire

Je réfléchis comment passer par VBA
Merci de m'accompagner dans ma réflexion et / ou me donner des ébauches de solution. Merci
 

Pièces jointes

  • Traitement_BD.xlsm
    10.9 KB · Affichages: 18
Trier par date Trier par votes
KTM

KTM

XLDnaute Impliqué
BOISGONTIER à dit:
cf pj

Boisgontier
Cliquez pour agrandir...
Vos Codes marchent super bien . C'est extraordinaire!!!
Mais j'aimerais pour ne pas être automate avoir des petits commentaires ou explications pour déchiffrer et comprendre comment ça fonctionne.
Autre chose j'ai remarqué qu'il n'ya pas de déclaration des variables ce qui fait que sur un fichier avec "Option Explicite" ça coince.
Merci
Sub essai()
Set Rng = Range("D2:D" & [D65000].End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For Each c In Rng
d(c.Value) = ""
Next c
For Each c In d.keys
Set d1 = CreateObject("scripting.dictionary")
For Each k In Rng
If k.Value = c And k.Offset(, 1) = "RUPTURE" Then
temp = k.Offset(, -3).Value
d1("temp") = d1("temp") & k.Offset(, -3).Value & ","
End If
Next k
For Each k In Rng
If k.Value = c And (k.Offset(, 1) = "STOCK DORMANT" Or k.Offset(, 1) = "SURSTOCK") Then
k.Offset(, 2).Value = d1("temp")
End If
Next k
Next c
End Sub

Sub essai2()
Set Rng = Range("D2:D" & [D65000].End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For Each c In Rng
d(c.Value) = ""
Next c
For Each c In d.keys
Set d1 = CreateObject("scripting.dictionary")
For Each k In Rng
If k.Value = c And (k.Offset(, 1) = "STOCK DORMANT" Or k.Offset(, 1) = "SURSTOCK") Then
temp = k.Offset(, -3).Value
d1("temp") = d1("temp") & k.Offset(, -3).Value & ","
End If
Next k
For Each k In Rng
If k.Value = c And k.Offset(, 1) = "RUPTURE" Then
k.Offset(, 2).Value = d1("temp")
End If
Next k
Next c
End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour KTM, JE, JB,

On peut se passer de VBA avec cette formule matricielle en F2 du fichier joint :

=SIERREUR(INDEX($A:$A;PETITE.VALEUR(SI($E2<>"RUPTURE";SI(($D$2:$D$1000=$D2)*($E$2:$E$1000="RUPTURE");LIGNE($E$2:$E$1000));SI(($D$2:$D$1000=$D2)*($E$2:$E$1000<>"RUPTURE");LIGNE($E$2:$E$1000)));COLONNES($F2:F2)));"")

à valider par Ctrl+Maj+Entrée tirer à droite et vers le bas.

Les résultats ne sont pas concaténés mais dans des cellules adjacentes.

A+
 

Pièces jointes

  • Traitement_BD(1).xlsm
    19.5 KB · Affichages: 14
Vote positif 0 Vote négatif
KTM

KTM

XLDnaute Impliqué
job75 à dit:
Bonjour KTM, JE, JB,

On peut se passer de VBA avec cette formule matricielle en F2 du fichier joint :

=SIERREUR(INDEX($A:$A;PETITE.VALEUR(SI($E2<>"RUPTURE";SI(($D$2:$D$1000=$D2)*($E$2:$E$1000="RUPTURE");LIGNE($E$2:$E$1000));SI(($D$2:$D$1000=$D2)*($E$2:$E$1000<>"RUPTURE");LIGNE($E$2:$E$1000)));COLONNES($F2:F2)));"")

à valider par Ctrl+Maj+Entrée tirer à droite et vers le bas.

Les résultats ne sont pas concaténés mais dans des cellules adjacentes.

A+
Cliquez pour agrandir...
Puissante et extraordinaire formule
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour KTM, JB,

J'y vais de ma solution VBA :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, ub&, d1 As Object, d2 As Object, i&, x$, j&, liste1$, liste2$, k&
Application.ScreenUpdating = False
Application.EnableEvents = False
Columns(7).Insert 'colonne auxiliaire
With [A1].CurrentRegion.Resize(, 7)
    .Cells(1, 7) = 1: .Columns(7).DataSeries 'numérotation
    .Sort .Columns(4), Header:=xlYes 'tri sur la colonneD
    tablo = .Value
    ub = UBound(tablo)
    Set d1 = CreateObject("Scripting.Dictionary")
    d1.Comparemode = vbTextCompare 'la casse est ignorée
    Set d2 = CreateObject("Scripting.Dictionary")
    d2.Comparemode = vbTextCompare 'la casse est ignorée
    For i = 2 To ub
        x = UCase(tablo(i, 4))
        d1.RemoveAll: d2.RemoveAll 'RAZ
        For j = i To ub
            If UCase(tablo(j, 4)) <> x Then Exit For
            If UCase(tablo(j, 5)) = "RUPTURE" Then d1(tablo(j, 1)) = "" Else d2(tablo(j, 1)) = ""
        Next j
        liste1 = Join(d1.keys, ","): liste2 = Join(d2.keys, ",")
        For k = i To j - 1
            tablo(k, 6) = IIf(UCase(tablo(k, 5)) = "RUPTURE", liste2, liste1)
        Next k
        i = j - 1
    Next i
    .Columns(6) = Application.Index(tablo, , 6) 'restitution
    .Sort .Columns(7), xlAscending, Header:=xlYes 'ordre initial
End With
Columns(7).Delete
Application.EnableEvents = True
End Sub
Le tri préalable sur la colonne D permet de gagner du temps.

Notez que les listes obtenues ne contiennent pas de doublons grâce aux 2 Dictionary.

A+
 

Pièces jointes

  • Traitement_BD VBA(1).xlsm
    24.7 KB · Affichages: 20
Dernière édition:
Vote positif 0 Vote négatif
KTM

KTM

XLDnaute Impliqué
job75 à dit:
Bonjour KTM, JB,

J'y vais de ma solution VBA :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, ub&, d1 As Object, d2 As Object, i&, x$, j&, liste1$, liste2$, k&
Application.ScreenUpdating = False
Application.EnableEvents = False
Columns(7).Insert 'colonne auxiliaire
With [A1].CurrentRegion.Resize(, 7)
    .Cells(1, 7) = 1: .Columns(7).DataSeries 'numérotation
    .Sort .Columns(4), Header:=xlYes 'tri sur la colonneD
    tablo = .Value
    ub = UBound(tablo)
    Set d1 = CreateObject("Scripting.Dictionary")
    d1.Comparemode = vbTextCompare 'la casse est ignorée
    Set d2 = CreateObject("Scripting.Dictionary")
    d2.Comparemode = vbTextCompare 'la casse est ignorée
    For i = 2 To ub
        x = UCase(tablo(i, 4))
        d1.RemoveAll: d2.RemoveAll 'RAZ
        For j = i To ub
            If UCase(tablo(j, 4)) <> x Then Exit For
            If UCase(tablo(j, 5)) = "RUPTURE" Then d1(tablo(j, 1)) = "" Else d2(tablo(j, 1)) = ""
        Next j
        liste1 = Join(d1.keys, ","): liste2 = Join(d2.keys, ",")
        For k = i To j - 1
            tablo(k, 6) = IIf(UCase(tablo(k, 5)) = "RUPTURE", liste2, liste1)
        Next k
        i = j - 1
    Next i
    .Columns(6) = Application.Index(tablo, , 6) 'restitution
    .Sort .Columns(7), xlAscending, Header:=xlYes 'ordre initial
End With
Columns(7).Delete
Application.EnableEvents = True
End Sub
Le tri préalable sur la colonne D permet de gagner du temps.

Notez que les listes obtenues ne contiennent pas de doublons grâce aux 2 Dictionary.

A+
Cliquez pour agrandir...
C'est impeccable
ET si on voulait avoir le résultat dans une liste déroulante ?
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
KTM à dit:
ET si on voulait avoir le résultat dans une liste déroulante ?
Cliquez pour agrandir...
Il suffit de créer la liste de validation de la cellule active en colonne F, la macro dans ce fichier (2) :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[F:F].Validation.Delete 'RAZ
If ActiveCell.Column <> 6 Or ActiveCell.Row = 1 Then Exit Sub
If ActiveCell(1, 0) = "" Then Exit Sub
Dim x, h&, ligdeb&, d1 As Object, d2 As Object, i&
With [A1].CurrentRegion.Resize(, 7)
    x = .Cells(ActiveCell.Row, 4)
    h = Application.CountIf(.Columns(4), x)
    If h = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Columns(7).Insert 'colonne auxiliaire
    .Cells(1, 7) = 1: .Columns(7).DataSeries 'numérotation
    .Sort .Columns(4), Header:=xlYes 'tri sur la colonne D
    ligdeb = Application.Match(x, .Columns(4), 0)
    Set d1 = CreateObject("Scripting.Dictionary")
    d1.Comparemode = vbTextCompare 'la casse est ignorée
    Set d2 = CreateObject("Scripting.Dictionary")
    d2.Comparemode = vbTextCompare 'la casse est ignorée
    For i = ligdeb To ligdeb + h - 1
        If UCase(.Cells(i, 5)) = "RUPTURE" Then d1(.Cells(i, 1).Value) = "" Else d2(.Cells(i, 1).Value) = ""
    Next
    .Sort .Columns(7), xlAscending, Header:=xlYes 'ordre initial
End With
ActiveCell.Validation.Add xlValidateList, Formula1:=IIf(UCase(ActiveCell(1, 0)) = "RUPTURE", Join(d2.keys, ","), Join(d1.keys, ","))
Columns(7).Delete
End Sub
 

Pièces jointes

  • Traitement_BD VBA(2).xlsm
    25.9 KB · Affichages: 7
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2021 calcul : Somme des quantités de chaque produit à fabriquer
Réponses
3
Affichages
455
MinstrelL
M
P
  • Question
Microsoft 365 gestion de stock avec plusieurs date de production sur même produit
Réponses
12
Affichages
1 K
pouetpouetlagalette
P
B
  • Question
Microsoft 365 Base de données sur exel
Réponses
9
Affichages
432
bernypiz
B
B
  • Question
XL 2010 Base de données - Identifier des associations entre les données de mes colonnes
Réponses
3
Affichages
596
Bibinaire
B
A
  • Résolu(e)
XL 2019 Créer une base de données à partir de plusieurs fichiers excel source
Réponses
7
Affichages
747
adrien786
A
E
  • Question
XL 2019 Identification des doublons sur la base des attributs de produits
Réponses
3
Affichages
526
ExcelBeginner
E
B
  • Question
XL 2013 quelle base de données excel faire pour faire des tcd multi tables ?
Réponses
6
Affichages
733
chris
chris
Jean-Luc ANDRET
  • Question
XL 2019 Gestion de stock à partir d'une vente
Réponses
1
Affichages
2 K
JM27
J
B
  • Question
Microsoft 365 Choix d'un dépôt en fonction de plusieurs critères
Réponses
1
Affichages
432
Chris401
Chris401
J
  • Question
XL 2016 Probléme VBA de transfert de données
Réponses
1
Affichages
544
julien741
J

Membres actuellement en ligne

24 membres et 339 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 101
Messages
2 085 300
Membres
102 857
dernier inscrit
Nony1931