Tri en masse Excel 2007

Résolu
Dauphins -  
pijaku Messages postés 13513 Statut Modérateur -
Bonjour,

Je n'arrive pas à mettre en place sur excel un tri. Mon niveau et très bas aussi.

Je fais une extraction de ma base de donnée AS400 vers excel sur la feuille 1, cela représente 50 000 références.
Chaque référence a :
Code Fourisseur / Ref / Description / Prix / Famille / Ss famille.

J'aimerai pouvoir créer un tri qui me permettrait de mettre dans différentes feuille les références ayant les memes famille / ss famille

Pouvez vous m'aider svp ?

Merci



A voir également:

25 réponses

Précédent
  • 1
  • 2
Réponse 21 / 25
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Alors voici l'ensemble des codes regroupés en deux macros et une fonction...
Durée d'exécution chez moi (pour te donner un ordre d'idée) pour 35 000 lignes : 29 secondes 25 centièmes... 
Option Explicit
Option Base 1

Sub Repartition()
Dim DicoConcat As Object
Dim concat(), Colonns(), TablDico(), Symb()
Dim DrLig As Long, i As Long, j As Long, Lig As Long, Col As Long
Dim Wsh As Worksheet
Dim Trouve As Range
Dim Message As String
Dim test As Boolean

Application.ScreenUpdating = False
'-----------------------------------------------'
'------ Effacement des symboles colonne C ------'
'-----------------------------------------------'
Symb = Array(">", "<", "-", "+", "=", "$") 'tu peux ajouter ici autant de symboles que nécessaire!!!
With Sheets("Feuil1")
    DrLig = .Range("C" & Rows.Count).End(xlUp).Row
    For Lig = 1 To DrLig
        For i = LBound(Symb) To UBound(Symb)
            If InStr(.Cells(Lig, 3), Symb(i)) <> 0 Then
                .Cells(Lig, 3) = Replace(.Cells(Lig, 3), Symb(i), "")
            End If
        Next i
    Next Lig
'------------------------------------------------------------'
'-- remplissage des variables avec le contenu de la Feuil1 --'
'------------------------------------------------------------'
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim concat(DrLig)
    ReDim Colonns(1 To DrLig, 1 To 6)
    For i = 2 To DrLig
        For j = 1 To 6
            'Colonns = toutes les données deFeuil1
            Colonns(i - 1, j) = .Cells(i, j)
        Next j
        'concat = concaténation des colonnes E & F
        concat(i - 1) = Colonns(i - 1, 5) & "_" & Colonns(i - 1, 6)
    Next i
End With
'-------------------------------------------------------------'
'-- Etablit la liste sans doublons des Familles_ss familles --'
'-------------------------------------------------------------'
Set DicoConcat = CreateObject("Scripting.Dictionary")
For i = LBound(concat) To UBound(concat)
    DicoConcat(concat(i)) = ""
Next i
'-------------------------------------------------------------'
'- Compte si le futur nombre de feuilles est supérieur à 250 -'
'-------------------------------------------------------------'
If DicoConcat.Count + ThisWorkbook.Worksheets.Count >= 250 Then
    MsgBox "Votre classeur va dépasser les 250 feuilles. Fractionnez le au préalable."
    Exit Sub
End If
'-------------------------------------------------------------'
'------ Création des feuilles nommées Famille_Ss Famille -----'
'-------------------------------------------------------------'
TablDico = DicoConcat.keys
'Si vous souhaitez tester si la feuille a déjà été créée
'enlevez les apostrophes en début des lignes suivantes
For i = 0 To UBound(TablDico) - 1
'    If FeuilleExiste(TablDico(i)) = False Then
        ThisWorkbook.Worksheets.Add
        With ActiveSheet
            .Name = TablDico(i)
            .Range("A1") = "Fournisseur"
            .Range("B1") = "Ref"
            .Range("C1") = "Description"
            .Range("D1") = "Prix"
            .Range("E1") = "Famille"
            .Range("F1") = "Sous famille"
'-------------------------------------------------------------'
'------ remplit les feuilles nommées Famille_Ss Famille ------'
'-------------------------------------------------------------'
            For j = 1 To UBound(concat)
                If concat(j) = TablDico(i) Then
                    Lig = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
                    For Col = 1 To 6
                        .Cells(Lig, Col) = Colonns(j, Col)
                    Next
                End If
            Next j
        End With
'    Else
'        With Sheets(concat)
'            .Cells.Clear
'        End With
'    End If
Next i
Sheets("Feuil1").Select
'-------------------------------------------------------------'
'---- Renomme les feuilles en fonction d'une liste Feuil2 ----'
'-------------------------------------------------------------'
test = False
Message = "Les feuilles suivantes n'ont pas pu être renommées : " & Chr(10)
For Each Wsh In ThisWorkbook.Worksheets
    With Sheets("Feuil2")
        Set Trouve = .Columns(1).Cells.Find(Wsh.Name, LookAt:=xlWhole)
            If Trouve Is Nothing Then
                Message = Message & Chr(10) & Wsh.Name
                test = True
            ElseIf Trouve.Offset(0, 1) <> "" Then
                If FeuilleExiste(Trouve.Offset(0, 1).Value) Then
                    Message = Message & Chr(10) & Trouve.Value
                    test = True
                Else
                    Wsh.Name = Trouve.Offset(0, 1).Value
                End If
            End If
        Set Trouve = Nothing
    End With
Next
If test = True Then
    MsgBox Message
Else
    MsgBox "Toutes les feuilles ont été renommées"
End If
End Sub

Function FeuilleExiste(NomFeuille) As Boolean
    Dim f As Object
    On Error Resume Next
    Set f = Sheets(NomFeuille)
    If Err = 0 Then FeuilleExiste = True
    Set f = Nothing
End Function

Sub ListeFamillesSousFamilles()
Dim DicoConcat As Object
Dim concat()
Dim DrLig As Long, i As Long, j As Long

Application.ScreenUpdating = False
With Sheets("Feuil1")
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim concat(DrLig)
    For i = 2 To DrLig
        concat(i - 1) = .Cells(i, 5) & "_" & .Cells(i, 6)
    Next i
End With
Set DicoConcat = CreateObject("Scripting.Dictionary")
For i = LBound(concat) To UBound(concat)
    DicoConcat(concat(i)) = ""
Next i
With Sheets("Feuil2")
    .Range("A1").Resize(DicoConcat.Count) = Application.Transpose(DicoConcat.keys)
End With
End Sub
0
Réponse 22 / 25
Dauphins
 
Ok mais cela ne renomme pas. Comment dois-je faire pour mettre les noms de remplacement et qu'il le fasse automatiquement ?
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Pour réaliser le tout, 3 étapes :
1- tu lances la macro ListeFamillesSousFamilles
2- en feuil2 Colonne B tu mets tes noms de feuille : pomme, poire banane ...
3- tu lances la macro Repartition
0
Réponse 23 / 25
Dauphins
 
Cela ne fonctionne pas. Quand je lance Répartition, il m'ouvre une fenêtre me listant toutes les fenêtres n'ayant pas pu être renommées, bref toutes. Quand je la ferme il me tri quand même les références

N'est il pas possible que la fenêtre 2 sois déjà écrite dès le départ afin d'éviter aux personnes utilisant cela de tout faire à chaque fois a la main ?
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Bonjour,
Si tu suis les 3 étapes mentionnées ci dessus, tout fonctionne.
En fait, les trois cas ou les feuilles ne sont pas renommées sont :
- le nouveau de nom de feuille (pomme par exemple) existe déjà dans ce même classeur,
- le "couple" Famille-Sous Famille n'a pas été trouvé Feuil2
- Si la colonne B Feuil2 n'est pas remplie pour le couple Famille-sous famille concerné.

On peux tout automatiser, si tu le souhaites. Je crois avoir compris que tes noms de feuilles (pomme, poire, banane...) ne sont pas donnés au hasard, et sont, en fait, des extraits des noms de familles (ou de sous familles). Si tu veux que la macro fasse tout toute seule, dis moi comment sont construits ces noms de feuilles (pomme, poire)?
0
Réponse 24 / 25
Dauphins
 
Bonjour, je viens de réessayé et cela ne fonctionne pas. Je lance la première macro, dans la feuille 2 il me créait une liste en colonne A, donc en B je mets en face des noms, banane, pomme...
Je lance ensuite la deuxième macro et cela me produit une fenêtre pour m'indiquer que toute n'ont pas pu être renommée, et me fait le tri.

Est-il possible que dans le code tu mets par défaut 2_1 = banane.... ? Comme cela tout est automatique.
0
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Oui, donne moi la liste des correspondances pour tous les cas...
0
Dauphins
 
Peux tu me donner ton mail ? Je t'envoie comme cela l'extraction de ma BD et tu verras pourquoi cela ne marche pas chez moi
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 25 / 25
pijaku Messages postés 13513 Statut Modérateur 2 763
 
Bonjour,

Problème résolu par MP, du à un souci sur les données, présence de caractères spéciaux dans les noms de feuilles...
La macro finale semble donc bien "tourner".
Voici son code, au cas ou... : 

Option Explicit

Option Base 1


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
'----- SOURCES Pédagogiques :

    '- Pour les variables tableaux :
'http://boisgontierjacques.free.fr/pages_site/tableaux.htm
'http://silkyroad.developpez.com/vba/tableaux/

    '- Pour les objets Dictionary (merci Michel_m ;-)) :
'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm

    '- Pour le tri des onglets :
'http://www.commentcamarche.net/forum/affich-3356070-vba-trier-les-feuilles#1

    'En général :
'http://www.commentcamarche.net/forum/

    'et en particulier pour la Function FeuilleExiste :
'http://www.developpez.net/forums/f542/logiciels/microsoft-office/excel/
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'

Sub Repartition()
Dim DicoConcat As Object
Dim concat(), Colonns(), TablDico(), Symb()
Dim DrLig As Long, i As Long, j As Long, Lig As Long, Col As Long
Dim Boucle As Integer, Compteur As Integer
Dim Wsh As Worksheet
Dim Trouve As Range
Dim Message As String
Dim test As Boolean
Dim t

t = Timer
Application.ScreenUpdating = False
'------------------------------------------------------'
'------ Effacement des symboles colonne C Feuil1 ------'
'------------------------------------------------------'
Symb = Array(">", "<", "-", "+", "=", "$") 'tu peux ajouter ici autant de symboles que nécessaire!!!
With Sheets("Feuil1")
    DrLig = .Range("C" & Rows.Count).End(xlUp).Row
    For Lig = 1 To DrLig
        For i = LBound(Symb) To UBound(Symb)
            If InStr(.Cells(Lig, 3), Symb(i)) <> 0 Then
                .Cells(Lig, 3) = Replace(.Cells(Lig, 3), Symb(i), "")
            End If
        Next i
    Next Lig
'------------------------------------------------------------'
'-- remplissage des variables avec le contenu de la Feuil1 --'
'------------------------------------------------------------'
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim concat(DrLig)
    ReDim Colonns(1 To DrLig, 1 To 6)
    For i = 2 To DrLig
        For j = 1 To 6
            'Colonns = toutes les données deFeuil1
            Colonns(i - 1, j) = .Cells(i, j)
        Next j
        'concat = concaténation des colonnes E & F
        concat(i - 1) = Colonns(i - 1, 5) & "_" & Colonns(i - 1, 6)
    Next i
End With
'-------------------------------------------------------------'
'-- Etablit la liste sans doublons des Familles_ss familles --'
'-------------------------------------------------------------'
Set DicoConcat = CreateObject("Scripting.Dictionary")
For i = LBound(concat) To UBound(concat)
    DicoConcat(concat(i)) = ""
Next i
'-------------------------------------------------------------'
'- Compte si le futur nombre de feuilles est supérieur à 250 -'
'-------------------------------------------------------------'
If DicoConcat.Count + ThisWorkbook.Worksheets.Count >= 250 Then
    MsgBox "Votre classeur va dépasser les 250 feuilles. Fractionnez le au préalable."
    Exit Sub
End If
'-------------------------------------------------------------'
'------ Création des feuilles nommées Famille_Ss Famille -----'
'-------------------------------------------------------------'
TablDico = DicoConcat.keys
For i = 0 To UBound(TablDico) - 1
'-------------------------------------------------------------'
'------ Cas d'une feuille déjà existante - TEST cf + bas -----'
'------ Si vous souhaitez ajouter ce test de sécurité à ------'
'------ la procédure, enlevez les ' en début des lignes ------'
'------ référencées par 'suppr(') en fin de ligne... ---------'
'-------------------------------------------------------------'
'    If FeuilleExiste(TablDico(i)) = False Then                                 'suppr(')
        ThisWorkbook.Worksheets.Add
        With ActiveSheet
            .Name = TablDico(i)
            .Range("A1") = "Fournisseur"
            .Range("B1") = "Ref"
            .Range("C1") = "Description"
            .Range("D1") = "Prix"
            .Range("E1") = "Famille"
            .Range("F1") = "Sous famille"
'-------------------------------------------------------------'
'------ remplit les feuilles nommées Famille_Ss Famille ------'
'-------------------------------------------------------------'
            For j = 1 To UBound(concat)
                If concat(j) = TablDico(i) Then
                    Lig = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
                    For Col = 1 To 6
                        .Cells(Lig, Col) = Colonns(j, Col)
                    Next
                End If
            Next j
        End With
'-------------------------------------------------------------'
'------ Cas d'une feuille déjà existante - Cf test + haut ----'
'--- On supprime tout ce qu'elle contenait et on la remplit --'
'-------------------------------------------------------------'
'    Else                                                                       'suppr(')
'        With Sheets(concat)                                                    'suppr(')
'            .Cells.Clear                                                       'suppr(')
'            .Range("A1") = "Fournisseur"                                       'suppr(')
'            .Range("B1") = "Ref"                                               'suppr(')
'            .Range("C1") = "Description"                                       'suppr(')
'            .Range("D1") = "Prix"                                              'suppr(')
'            .Range("E1") = "Famille"                                           'suppr(')
'            .Range("F1") = "Sous famille"                                      'suppr(')
'            For j = 1 To UBound(concat)                                        'suppr(')
'                If concat(j) = TablDico(i) Then                                'suppr(')
'                    Lig = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row  'suppr(')
'                    For Col = 1 To 6                                           'suppr(')
'                        .Cells(Lig, Col) = Colonns(j, Col)                     'suppr(')
'                    Next                                                       'suppr(')
'                End If                                                         'suppr(')
'            Next j                                                             'suppr(')
'        End With                                                               'suppr(')
'    End If                                                                     'suppr(')
Next i
Sheets("Feuil1").Select
'-------------------------------------------------------------'
'---- Renomme les feuilles en fonction d'une liste Feuil2 ----'
'-------------------------------------------------------------'
test = False
Message = "Les feuilles suivantes n'ont pas pu être renommées : " & Chr(10)
For Each Wsh In ThisWorkbook.Worksheets
    With Sheets("Feuil2")
        Set Trouve = .Columns(1).Cells.Find(Wsh.Name, LookAt:=xlWhole)
            If Trouve Is Nothing Then
                Message = Message & Chr(10) & Wsh.Name
                test = True
            ElseIf Trouve.Offset(0, 1) <> "" Then
                If FeuilleExiste(Trouve.Offset(0, 1).Value) Then
                    Message = Message & Chr(10) & Trouve.Value
                    test = True
                Else
                    Wsh.Name = Trouve.Offset(0, 1).Value
                End If
            Else
                Message = Message & Chr(10) & Trouve.Value
                test = True
            End If
        Set Trouve = Nothing
    End With
Next
'-------------------------------------------------------------'
'-------- Trie les feuilles dans l'ordre alphabétique --------'
'-------------------------------------------------------------'
For Boucle = 1 To Sheets.Count
    If Sheets(Boucle).Visible = True Then
        For Compteur = 1 To (Boucle - 1)
            If Sheets(Compteur).Visible = True Then
                If (UCase(Sheets(Boucle).Name) < UCase(Sheets(Compteur).Name)) Then
                    Sheets(Boucle).Move before:=Sheets(Compteur)
                    Exit For
                End If
            End If
        Next Compteur
    End If
Next Boucle
Sheets("Feuil1").Select
'-------------------------------------------------------------'
'--------- Fin de la macro / message à l'utilisateur ---------'
'-------------------------------------------------------------'
If test = True Then
    MsgBox "Procédure terminée en : " & Timer - t & " Secondes!" & Chr(10) & Message
Else
    MsgBox "Procédure terminée en : " & Timer - t & " Secondes!" & Chr(10) & "Toutes les feuilles ont été renommées"
End If
End Sub

Function FeuilleExiste(NomFeuille) As Boolean
    Dim f As Object
    On Error Resume Next
    Set f = Sheets(NomFeuille)
    If Err = 0 Then FeuilleExiste = True
    Set f = Nothing
End Function
0