[Résolu] Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles

[fanadegra]

Bonjour à tous et merci pour le temps que vous consacrez à ma demande :

- j'ai une base de données sur une feuille "BASE" dont la 1ere colonne contient des dates et les colonnes suivantes des données qui sont nombreuses.

- l'objectif est de trier les données en fonction des infos qu'il y a dans les colonnes B à E de la feuille "BASE" et donc de créer une feuille pour chaque éléments différents de ces colonnes B à E.

j'ai mis un fichier xls où il y a les explications très claires, et en exemple le resultat souhaité pour plus de précision.


merci beaucoup pour votre aide ou une partie de la solution car je ne connais rien en macro,

j'ai cherché sur le forum mais je n'ai rien trouvé pour l'instant.

bon we

 

[Robert]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonsoir Fanadegra, bonsoir le forum,

En pièce jointe ton fichier avec le code ci-dessous :

Sub Macro1()
Dim b As Object 'déclare la variable b (onglet Base)
Dim i As Byte 'déclare la variable i (Incrément)
Dim et As Range 'déclare la variable et (En-Tête)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim d As Object 'déclare la variable d (Dictionnaire)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim tmp As Variant 'déclare la variable tmp (tableau TeMPoraire)
Dim j As Byte 'déclare la variable j (incrément)
Dim od As Object 'déclare la variable od (Onglet de Destination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set b = Sheets("Base") 'définit l'onglet b
Set et = b.Rows("1:4") 'définit l'en-ête et
For i = 2 To 5 'boucle 1 : sur les colonnes 2 à 5 (B à E)
    dl = b.Cells(Application.Rows.Count, i).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne i de la boucle 1
    Set pl = b.Range(b.Cells(5, i), b.Cells(dl, i)) 'définit la plage pl de la colonne i de la boucle
    Set d = CreateObject("Scripting.Dictionary") 'définit le dictionnaire d
    For Each cel In pl 'boucle 2 : sur toutes les cellules cel de la plage pl
        cel.Value = Trim(cel.Value) 'supprime les espaces avant et après dans la valeur de la cellule (il y avait "PARIS" et "PARIS ")
        d(cel.Value) = "" 'alimente le dictionnaire d
    Next cel 'prochaine cellule de la boucle 2
    tmp = d.keys 'récupère dans le tableau temporaire tmp les valeurs uniques du dictionnaire (sans doublon)
    For j = 0 To UBound(tmp) 'boucle 3 : sur toutes les valeurs (uniques) du tableau temporaire tmp
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set od = Sheets(CStr(tmp(j))) 'définit l'onglet de destination od (génère une erreur si cet onglet n'existe pas)
        If Err <> 0 Then 'condition : si une erreur a été générée
            Err = 0 'annule l'erreur
            Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position
            ActiveSheet.Name = CStr(tmp(j)) 'renomme l'onglet avec la valeur unique de la boucle 3
            Set od = Sheets(CStr(tmp(j))) 'définit l'onglet de destination od
        End If 'fin de la condition
        On Error GoTo 0 'annule la gestion des erreurs
        od.Cells.Clear 'vide toutes les cellules de l'onglet od (les éventuelles anciennes données de cet onglet)
        et.Copy 'copy l'en-tête et
        od.Range("A1").PasteSpecial (xlPasteColumnWidths) 'collage spécial de la largeur des colonnes)
        et.Copy od.Range("A1") 'copie et colle l'en-tête en A1
        'Application.CutCopyMode = False 'supprime le clignotement lié au "copier"
        od.Range("A1").Select 'sélectionne la cellule A1 de l'onglet de destination
        'filtre la colonne i de l'onglet b avec la valeur unique de la boucle 3 comme critère
        b.Range("A4").AutoFilter Field:=i, Criteria1:=tmp(j)
        'copie les lignes entière des cellules visible de la plage pl et les colle dans la cellule A5 de l'onglet od
        pl.SpecialCells(xlCellTypeVisible).EntireRow.Copy od.Range("A5")
        'colore la colonne i de l'onglet od
        Application.Intersect(od.UsedRange, od.Columns(i)).Interior.ColorIndex = 40
        b.Range("A1").AutoFilter 'supprime le filtre automatique
    Next j 'prochaine valeur unique de la boucle 3
    Set d = Nothing 'efface le dictionanire d
    Set tmp = Nothing 'efface le tableau temporaire tmp
    Set pl = Nothing 'efface la plage pl (la variable, pas le contenu)
Next i 'prochaine colonne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Le fichier :

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonjour fanadegra, Robert ,

Un essai dans le fichier joint. On utilise une fenêtre pour choisir la colonne à ventiler.


Le fonctionnement nécessite l'activation de la référence à "Microsoft Scripting Runtime". Pour cela:
.

• Se placer dans l'éditeur VBA (touches Alt+F11)
• Sélectionner le menu "Outils / Références..."
• Dans la boîte de dialogue, chercher "Microsoft Scripting RunTime"
• Cocher la case correspondante (si ce n'est pas déjà le cas) puis cliquer sur "OK"

rem: le nom des feuilles créées est précédé du nom de la colonne. En effet, rien n'indique que pour des colonnes différentes, on ne retrouve pas des éléments égaux (exemple toutes les colonnes INT contiennent la même valeur YYY. Le nom de la colonne différencie les feuilles de ventilation).

Edit: remis v1 suite msg #7 de fanadegra

Le code dans module1:

Sub Ventiler(NomCol$, NumCol&)

Dim maZone As Range, maCol As Range, xrg As Range
Dim sh As Worksheet
Dim i&, nom$
Dim dico As New Dictionary, maColValue, valeur

Application.ScreenUpdating = False
Set maZone = Sheets("BASE").Range("a4").CurrentRegion
Set maCol = maZone.Columns(NumCol)

'Effacement de toutes les feuilles pour la colonne NomCol
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
  If sh.Name Like NomCol & "*" Then sh.Delete
Next sh
Application.DisplayAlerts = True
maColValue = maCol.Value
'construction de la liste des items différents de la colonne
For i = 2 To UBound(maColValue)
  dico(maColValue(i, 1)) = ""
Next i

'boucle sur les items de la colonne
With Sheets("BASE")
  For Each valeur In dico.Keys
    Range("A4").AutoFilter
    Set sh = ThisWorkbook.Sheets.Add
    sh.Name = NomCol & "-" & valeur
    sh.Move after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    .Range("$A$4").AutoFilter Field:=NumCol, Criteria1:=valeur
    maZone.SpecialCells(xlCellTypeVisible).Copy sh.Range("a4")
    Set xrg = sh.Range("a4").Offset(, NumCol - 1)
    Set xrg = xrg.End(xlDown)
    Set xrg = sh.Range(sh.Range("a4").Offset(, NumCol - 1), xrg)
    xrg.Interior.Color = RGB(256, 64, 64)
  Next valeur
  .Range("A4").AutoFilter
  Application.Goto .Range("a1"), True
  Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
MsgBox "Ventilation terminée !"
End Sub

Le code du Userform1:

Private Sub cbnAnnuler_Click()
  Unload Me
End Sub

Private Sub cbnTrier_Click()
  If lbxCateg.ListIndex = -1 Then
    MsgBox "Veuillez sélectionner une colonne dans la liste."
  Else
    Ventiler lbxCateg.List(lbxCateg.ListIndex), lbxCateg.ListIndex + 1
    Unload Me
  End If
End Sub

Private Sub UserForm_Initialize()
Dim xcell As Range
  With Sheets("Base")
    For Each xcell In .Range(.Range("a4"), .Range("a4").End(xlToRight))
      lbxCateg.AddItem xcell
    Next xcell
  End With
End Sub

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

(re)Bonjour à tous,

Une version v2 qui devrait permettre de filtrer selon la date (ce que n'autorisait pas la v1)

Edit: remis v2 suite msg #7 de fanadegra

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

(re)Bonsoir,

Une dernière version (v3) qui autorise le choix simultané de plusieurs colonnes.

 

[fanadegra]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonjour le forum, bonjour Robert et bonjour Mapomme,

merci pour votre aide précieuse et votre rapidité et pour les différentes versions,
je regarde cela ce soir et je vous tiens au courant.

 

[fanadegra]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonjour le forum, bonjour Robert et bonjour Mapomme,

Merci Robert pour le fichier qui fonctionne parfaitement et pour les explications qui accompagnent le code, que je vais relire.

Merci Mapomme pour les 3 versions et pour l'userform et la possibilité de filtrer les autres colonnes. Pour les v2 et v3 j'ai un message d'erreur de compilation - projet ou bibliothèque introuvable avec le mot Format en inverse vidéo (dans la macro ventiler et en dessous de 'boucle sur les items de la colonne.

Merci à l'un et à l'autre pour votre aide très efficace.

Bonne journée

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonsoir le forum,

(...) Merci Mapomme pour les 3 versions et pour l'userform et la possibilité de filtrer les autres colonnes. Pour les v2 et v3 j'ai un message d'erreur de compilation - projet ou bibliothèque introuvable avec le mot Format en inverse vidéo (dans la macro ventiler et en dessous de 'boucle sur les items de la colonne. (...)

D'aucuns, s'il vous plait, pourraient ils me dire si les exécutions des fichiers v2 et/ou v3 (et au sein de quelle version d'Excel) aboutissent à une erreur ou non ? (cerise sur le gâteau: si erreur, à quelle instruction ?). Je n'arrive pas à reproduire l'erreur citée par fanadegra donc difficile pour moi de déverminer ces deux versions.

D'avance, merci.

 

[fanadegra]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

bonsoir Mapomme et merci pour ton aide

dans la macro ventiler
Sub Ventiler(NomCol$, NumCol&) est surligné en jaune

et le curseur reste sur Format en inverse video

j'espère que c'est un peu plus clair j'ai ouvert le fichier avec xml et une autre fois avec office 2010 est le blocage est au même niveau

Merci d'avance

Function SheetExists(xsh) As Boolean
'-----------------------------------------------------------
' renvoie TRUE si la feuille existe dans ce classeur
' xsh est soit une variable de type Sheet soit une variable
'  de type string représentant le nom de la feuille
'-----------------------------------------------------------
Dim verif
  On Error GoTo ExistePAS
  verif = ThisWorkbook.Sheets(xsh.Name).Range("a1")
  SheetExists = True
  Exit Function
ExistePAS:
  verif = ThisWorkbook.Sheets(xsh).Range("a1")
  SheetExists = True
  Exit Function
End Function

Sub Ventiler(NomCol$, NumCol&)
Dim maZone As Range, maCol As Range, xrg As Range
Dim sh As Worksheet
Dim i&, nom$
Dim dico As New Dictionary, maColValue, valeur

Application.ScreenUpdating = False
Set maZone = Sheets("BASE").Range("a4").CurrentRegion
Set maCol = maZone.Columns(NumCol)

'Effacement de toutes les feuilles pour la colonne NomCol
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
  If sh.Name Like NomCol & "*" Then sh.Delete
Next sh
Application.DisplayAlerts = True
maColValue = maCol.Value
'construction de la liste des items différents de la colonne
For i = 2 To UBound(maColValue)
  dico(maColValue(i, 1)) = ""
Next i

'boucle sur les items de la colonne
With Sheets("BASE")
  For Each valeur In dico.Keys
    Range("A4").AutoFilter
    Set sh = ThisWorkbook.Sheets.Add
    If VarType(valeur) = 7 Then
      sh.Name = NomCol & "-" & [B]Format[/B](valeur, "dd-mm-yy")
    Else
      sh.Name = NomCol & "-" & valeur
    End If
    sh.Move after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    .Activate
    If VarType(valeur) = 7 Then
      .Range("$A$4").AutoFilter Field:=NumCol, Field:=1, Operator:= _
        xlFilterValues, Criteria2:=Array(2, Format(valeur, "mm/dd/yyyy"))
    Else
      .Range("$A$4").AutoFilter Field:=NumCol, Criteria1:=valeur
    End If
    maZone.SpecialCells(xlCellTypeVisible).Copy sh.Range("a4")
    Set xrg = sh.Range("a4").Offset(, NumCol - 1)
    Set xrg = xrg.End(xlDown)
    Set xrg = sh.Range(sh.Range("a4").Offset(, NumCol - 1), xrg)
    xrg.Interior.Color = RGB(256, 64, 64)
  Next valeur
  .Range("A4").AutoFilter
  Application.Goto .Range("a1"), True
  Application.CutCopyMode = False
End With
Application.ScreenUpdating = True

End Sub

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonjour fanadegra,

Pouvez-vous tester ?:
Dans le classeur joint, quelle est la valeur en C1 après avoir cliqué sur le Bouton "test1" ?
Si erreur, quel est le message ?

 

[fanadegra]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

bonjour le forum, bonjour Mapomme

valeur en c1
30/04/11

merci pour votre aide

 

[mapomme]

Re : Tri de donnees feuille "Base" segmenter la base sur d'autres feuilles du classeu

Bonsoir fanadegra,

merci d'avoir testé.

Voici une version sans l'utilisation de l'instruction "Format". Pouvez-vous la tester et me retourner le résultat du test ?

 

[fanadegra]

[Résolu] : Tri de donnees feuille "Base" segmenter la base

bonjour le forum, bonjour Robert, bonjour Mapomme,

la version 4 est parfaite.

un grand merci à l'un et à l'autre pour vos 2 propositions qui correspondent à ma demande.
Merci pour le temps consacré et qui je l'espère profitera aux lecteurs du forum


NB je mets le fil en [Résolu]