XL 2016 Redistribuer et réorganiser plusieurs valeurs

Jauster

XLDnaute Occasionnel
Bonjour,

Je bloque sur la création d'un code en VBA: Voici mon problème :

J'ai un fichier avec plusieurs informations (cf. fichier joint). Les cellules avec un texte sont importants pour le problème alors que les cellules avec des "-" contiennent du texte dans le fichier original mais ce texte n'est pas important pour mon problème.

Colonne CODE : Identifiant unique du produit.
Colonne Type : Le produit peut être de type 1 ou de type 2 (classification du produit)
Colonne Q : Quantité.

Le but de la macro est de créer une nouvelle feuille (si elle n'existe pas déjà) pour chaque combinaison Date <> Type :
Exemple : Une feuille pour tous les produits de Type 1 avec pour date le 02.01.2018. Si il existe aussi des type 2 pour la même date, alors il faudra une deuxième feuille avec tous ces types 2.
J'aimerai également renommer mon onglet en fonction de ce qu'il contient sous la forme "Type - Date", mais je n'arrive pas à intégrer la date dans le nom de la feuille

Merci par avance
 

Pièces jointes

  • testmacro.xlsx
    11.5 KB · Affichages: 20
Dernière édition:

vgendron

XLDnaute Barbatruc
Hello

un début de code pour lister les feuilles à créer

il faut créer une feuille "Feuil1" pour y mettre les résultats

VB:
Sub feuilles()
Set dico = CreateObject("scripting.Dictionary")

With Sheets("A")
    fin = .UsedRange.Rows.Count
    For i = 2 To fin
        If Not dico.exists(Cells(i, 6) & "-" & Cells(i, 5)) Then
            dico.Add Cells(i, 6) & "-" & Cells(i, 5), i
        End If
    Next i
End With

With Sheets("Feuil1")
'MsgBox dico.Count
    .Range("A1").Resize(dico.Count) = Application.Transpose(dico.keys)
    .Range("B1").Resize(dico.Count) = Application.Transpose(dico.items)
End With

End Sub

En feuille "Feuil1" tu as
colonne A: le nom des feuilles à créer
colonne B: le numéro de la ligne associée de la feuille A
 

Jauster

XLDnaute Occasionnel
Hello Vgendron :)

Merci pour le code, je vais regarder et voir si il me va (décidément ca sera une année Tablo pour moi ^^).
Sinon de mon côté j'ai commencé à faire une boucle pour voir si la feuille existe et la créer si non. Le reste est aussi fait avec des boucles. Surement moins rapide qu'un dico, et surtout plus compliquer à mettre en place avec plusieurs boucles imbriquées.

Je reviens sur ce sujet dès que j'ai avancé.
 

vgendron

XLDnaute Barbatruc
Hello
voir PJ pour la création des feuilles "Type - Date"
pour vérifier si une feuille existe ou pas, plutot que de faire une boucle à chaque fois.. j'utilise un autre dictionnaire

voir les commentaires dans le code
pour l'instant.. je ne créé que des feuilles vierges
 

Pièces jointes

  • testmacro.xlsm
    26.1 KB · Affichages: 18

Jauster

XLDnaute Occasionnel
Hello,

Ton code pour créer les feuilles marche tres bien: J'ai de mon côté avancé sur le remplissage de ces feuilles.
VB:
Dim TabMass() As Variant

Set Dicomass = CreateObject("scripting.Dictionary")

With Sheets("A") 'dans la feuille "A"
    rows1 = .Cells(Rows.Count, "A").End(xlUp).Row 'rows count in sheet1
    TabMass = .Range("A2:L" & rows1).Value2


    For i = LBound(TabMass, 1) To UBound(TabMass, 1) 'on crée un dictionnaire pour avoir les EAN uniques
        Dicomass.Add TabMass(i, 1), i
    Next i

i = 1
For Each key In Dicomass.Keys
    If TabMass(i, 10) > 0 And TabMass(i, 1) <> "" Then
        maval = ("MASS - " & TabMass(i, 6) & " - " & CDate(TabMass(i, 5)))
        With Sheets(maval)
         .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMass(Dicomass.Item(key), 1)
         .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = TabMass(Dicomass.Item(key), 3)
         .Range("A" & .Rows.Count).End(xlUp).Offset(0, 2) = TabMass(Dicomass.Item(key), 10)
        End With
    End If

i = i + 1
Next key

Petite précision, les type 1 et 2 correspondent en réalité à Mono et Bom.
PS : J’espère avoir compris l'utilisation des dictionnaires, mais le résultat y ressemble deja
 
Dernière édition:

vgendron

XLDnaute Barbatruc
Hello
j'ai corrigé ton code pour qu'il soit compatible (niveau syntaxe des noms de feuilles) avec mon code
les deux codes suivants fonctionnent bien

VB:
Sub feuilles()
Application.ScreenUpdating = False
Set Dico = CreateObject("scripting.Dictionary") 'liste des feuilles à Créer
Set DicoFeuille = CreateObject("Scripting.dictionary") 'liste des feuilles déjà Créées

With Sheets("A") 'dans la feuille "A"
    fin = .UsedRange.Rows.Count 'dernière ligne
    For i = 2 To fin 'Dico=liste sans doublon des "Type - Date" (en remplacant le "/" par "."
        If Not Dico.exists(.Cells(i, 6) & "-" & WorksheetFunction.Substitute(.Cells(i, 5), "/", ".")) Then
            Dico.Add .Cells(i, 6) & "-" & WorksheetFunction.Substitute(.Cells(i, 5), "/", "."), i
        End If
    Next i
End With

With Sheets("Feuil1") 'juste pour le plaisir.. n'apporte rien à la suite de la macro
'MsgBox dico.Count
    .UsedRange.Clear 'on efface la feuille 1
    .Range("A1").Resize(Dico.Count) = Application.Transpose(Dico.Keys)
    .Range("B1").Resize(Dico.Count) = Application.Transpose(Dico.items)
End With

i = 1
For Each ws In Sheets 'on etabli la liste des feuilles existantes du classeur
    DicoFeuille.Add ws.Name, i
    i = i + 1
Next ws

For Each NomFeuille In Dico.Keys 'pour chaque feuille à Créer
    If Not DicoFeuille.exists(NomFeuille) Then 'si elle n'existe pas déjà
        ActiveWorkbook.Sheets.Add 'on ajoute une feuille
        ActiveSheet.Name = WorksheetFunction.Substitute(NomFeuille, "/", ".") 'on lui donne le nom "Type - Date"
        DicoFeuille.Add WorksheetFunction.Substitute(NomFeuille, "/", "."), i + 1 'on l'ajoute la liste des feuilles Créées
        i = i + 1
    End If
    'MsgBox NomFeuille
Next NomFeuille
Application.ScreenUpdating = True
End Sub

Sub RemplirFeuille()
Dim TabMass() As Variant

Set Dicomass = CreateObject("scripting.Dictionary")

With Sheets("A") 'dans la feuille "A"
    rows1 = .Cells(Rows.Count, "A").End(xlUp).Row 'rows count in sheet1
    TabMass = .Range("A2:L" & rows1).Value2


    For i = LBound(TabMass, 1) To UBound(TabMass, 1) 'on crée un dictionnaire pour avoir les EAN uniques
        Dicomass.Add TabMass(i, 1), i
    Next i
End With
i = 1
For Each Key In Dicomass.Keys
    If TabMass(i, 10) > 0 And TabMass(i, 1) <> "" Then
        'maval = ("MASS - " & TabMass(i, 6) & " - " & CDate(TabMass(i, 5)))
        maval = TabMass(i, 6) & "-" & WorksheetFunction.Substitute(CDate(TabMass(i, 5)), "/", ".")
        With Sheets(maval)
         .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMass(Dicomass.Item(Key), 1)
         .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = TabMass(Dicomass.Item(Key), 3)
         .Range("A" & .Rows.Count).End(xlUp).Offset(0, 2) = TabMass(Dicomass.Item(Key), 10)
        End With
    End If

i = i + 1
Next Key
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 721
Messages
2 081 927
Membres
101 842
dernier inscrit
seb0390