Résolu VBA, subtotal et classeur partagé

[Mickoik]

Bonjour à tous !

j'essaie depuis 4 jours de résoudre mon problème mais à chaque fois que je trouve une solution une nouvelle galère. J'ai envie de tout arrêter !
Je t'explique mon problème : j'ai une petite base de données crée par une macro.
Ca me sort :
en colonne A : une quantité
en colonne B : une référence
en colonne C : une date

Le truc c'est que la même référence apparaît plusieurs fois et que je voudrais avoir un résumé par date (en général il y a 2 ou 3 dates maximum) et la quantité par référence.

La première idée que j'ai eu : faire un tableau croisé dynamique. Résultat parfait mais mon classeur est partagé en permanence donc impossible.

J'ai mis trois jours à écrire ça :

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")
End Sub

Tout fonctionne parfaitement ! Je partage le classeur et HORREUR la fonction subtotal ne marche pas en mode partagé !!!!!

Please Help !

 

[Mickoik]

j'ai trouvé :

  Set d1 = CreateObject("Scripting.Dictionary")
  a = Range("AV2:AY" & [ba65000].End(xlUp).Row)
  j = 0
  For i = LBound(a) To UBound(a)
    If Not d1.exists(a(i, 2)) Then j = j + 1: d1(a(i, 2)) = j
  Next i
  Dim b():  ReDim b(1 To d1.Count, 1 To UBound(a, 2))
  For ligne = LBound(a) To UBound(a)
     p = d1(a(ligne, 2))
     b(p, 1) = b(p, 1) + a(ligne, 1)
     For k = 2 To 4: b(p, k) = a(ligne, k): Next k
  Next ligne
  [AR1].Resize(UBound(b), UBound(b, 2)) = b

   [AT1].Sort Key1:=[AT1], Order1:=xlAscending, Header:=xlYes

 

[magellan]

Merci d'avoir filé la réponse par toi-même, cela fait plaisir de voir que tu as cherché sans compter sur un tiers pour faire ton boulot Je mets donc ton post précédent en meilleure réponse pour que les gens aient une solution viable (nota: je n'ai pas vérifié )