Gerer Base de Données

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion KTM
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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

Trier par date Trier par votes
BOISGONTIER à dit:
Bonjour,

Je ne suis pas sûr d'avoir compris.

Boisgontier
Cliquez pour agrandir...
VOUS avez parfaitement compris.
Il reste maintenant à Paramétrer la macro de sorte que en face de chaque rupture on liste toutes les structures avec état stock DORMANT ou SURSTOCK comme illustré et le tour sera joué. Merci
 

Pièces jointes

Vote positif 0 Vote négatif
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😀" & [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😀" & [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
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

Vote positif 0 Vote négatif
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
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

Dernière édition:
Vote positif 0 Vote négatif
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
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

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

D
  • Résolu(e)
Microsoft 365 Graphique avec plage de données glissante en partant d'une date
Réponses
5
Affichages
621
Dégé59
D
V
  • Question Question
XL 2010 Remplissage de bulletin de transfert de stock selon la date depuis base de données articles (colonne variable)
Réponses
5
Affichages
1 K
Varenshar
V
A
  • Question Question
VBA Déduction automatisé dans une base de donnée stock.
Réponses
0
Affichages
869
Arnaud.hoarau
A
A
  • Question Question
Besoin d'aide pour VBA servant a modifier une base de données excel
Réponses
2
Affichages
2 K
adelaf
A
B
  • Question Question
Créer un base de données par macro Excel
Réponses
14
Affichages
3 K
berlan
B
H
  • Question Question
Excel en base de données ?
Réponses
5
Affichages
2 K
Guest
G
D
  • Question Question
[DEBUTANT]Extraction de données par Macro
Réponses
11
Affichages
2 K
_Thierry
_Thierry
Retour