Résolu VBA ranger par occurences

[Mickoik]

Bonjour,
j'essaie depuis plusieurs jours de faire une macro mais je n'y arrive pas :??:

J'ai une colonne dans laquelle apparaît une liste après avoir lancé une macro.
Le truc, c'est que cette liste s’entend sur beaucoup de lignes et je voudrait (comme le ferai un tableau croisé dynamique) afficher un résultat du type 3 références A, 2 références B etc.
Pour avoir un truc lisible facilement.
Si quelqu'un me me donner une piste .....
Merci !

 

[magellan]

C'est ta sortie qui est à trier. Nativement, la donnée apparaît donc en résultat "transparent", ce qui sous-entend qu'il n'y a pas de tri direct. tu devras chercher du côté des fonctions de tris afin de procéder au rangement après exécution du résultat.

 

[Mickoik]

et tu as une idée de comment faire ?

 

[magellan]

et tu as une idée de comment faire ?

Sub Tri_Article()
'Macro Dan pour zyglur
Dim plage As Range
Set plage = ActiveSheet.Range("A3:D" & Range("A" & Rows.Count).End(xlUp).Row)
plage.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, Orientation:=xlTopToBottom
End Sub

 

[magellan]

Vous devez être connecté pour voir les liens.

 

[Mickoik]

Merci mais cette macro ne me sert qu'a trier le tableau.
Ce que je cherche c'est à le résumer : si dans mon résultat j'ai 4 fois l'article A, alors au lieu de m'écrire 4 fois l'article A il m'écrit 4 Articles A.

et tu as une idée de comment faire ?

Sub Tri_Article()
'Macro Dan pour zyglur
Dim plage As Range
Set plage = ActiveSheet.Range("A3:D" & Range("A" & Rows.Count).End(xlUp).Row)
plage.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, Orientation:=xlTopToBottom
End Sub

 

[magellan]

Le souci est tout autre alors!
Cela sous-entend sortir dans un nouvel onglet un rapport?

 

[Mickoik]

Le souci est tout autre alors!
Cela sous-entend sortir dans un nouvel onglet un rapport?

Pourquoi pas du moment que ça fonctionne ...

 

[Mickoik]

j'ai écris ça. ça fait exactement ce que je veux mais gros problème mon classeur est partagé et la methode sous totaux ne fonctionne pas en mode partagé :fou:

Worksheets("pour recherche").Range("A2:D500").Clear
Worksheets("pour recherche").Outline.ShowLevels RowLevels:=5

Worksheets("Rechercher Client").Range("AV2:AX100").Select
    Selection.Copy
    Sheets("pour recherche").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=True, Transpose:=False
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "d/m/yyyy"

   Sheets("pour recherche").Range("A2").Select
    ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Add Key:=Range("C:C") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Add Key:=Range("B:B") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("pour recherche").Sort
        .SetRange Range("A2:C100")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(2), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(1), _
        Replace:=False, PageBreaks:=False, SummaryBelowData:=True
    ActiveSheet.Outline.ShowLevels RowLevels:=4
Dim tabl As Range

Set tabl = Sheets("pour recherche").Range("A2:C110")

derligne1 = Sheets("pour recherche").Range("B500").End(xlUp).Row
derligne2 = Sheets("pour recherche").Range("C500").End(xlUp).Row

Sheets("pour recherche").Rows(derligne1).Clear
Sheets("pour recherche").Rows(derligne2).Clear

For Each macellule In tabl
If macellule.Value = "" Then
macellule.Clear
End If
Next

derligne3 = Sheets("pour recherche").Range("C500").End(xlUp).Row
Set resultat = Sheets("pour recherche").Range("A2:C" & derligne3).SpecialCells(xlVisible)
resultat.Copy Destination:=Sheets("Rechercher Client").Range("W9")

 

[drul]

Toujours besoin d'aide ?