Votre question
Résolu

VBA, subtotal et classeur partagé

Tags :
  • Microsoft Excel
  • Programmation
Dernière réponse : dans Programmation
27 Décembre 2016 15:36:21

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 :
  1. Worksheets("Rechercher Client").Range("AV2:AX100").Select
  2. Selection.Copy
  3. Sheets("pour recherche").Select
  4. Range("A2").Select
  5. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  6. :=True, Transpose:=False
  7. Columns("C:C").Select
  8. Application.CutCopyMode = False
  9. Selection.NumberFormat = "d/m/yyyy"
  10. Sheets("pour recherche").Range("A2").Select
  11. ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Clear
  12. ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Add Key:=Range("C:C") _
  13. , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  14. ActiveWorkbook.Worksheets("pour recherche").Sort.SortFields.Add Key:=Range("B:B") _
  15. , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  16. With ActiveWorkbook.Worksheets("pour recherche").Sort
  17. .SetRange Range("A2:C100")
  18. .Header = xlGuess
  19. .MatchCase = False
  20. .Orientation = xlTopToBottom
  21. .SortMethod = xlPinYin
  22. .Apply
  23. End With
  24. Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(2), _
  25. Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  26. Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(1), _
  27. Replace:=False, PageBreaks:=False, SummaryBelowData:=True
  28. ActiveSheet.Outline.ShowLevels RowLevels:=4
  29. Dim tabl As Range
  30. Set tabl = Sheets("pour recherche").Range("A2:C110")
  31. derligne1 = Sheets("pour recherche").Range("B500").End(xlUp).Row
  32. derligne2 = Sheets("pour recherche").Range("C500").End(xlUp).Row
  33. Sheets("pour recherche").Rows(derligne1).Clear
  34. Sheets("pour recherche").Rows(derligne2).Clear
  35. For Each macellule In tabl
  36. If macellule.Value = "" Then
  37. macellule.Clear
  38. End If
  39. Next
  40. derligne3 = Sheets("pour recherche").Range("C500").End(xlUp).Row
  41. Set resultat = Sheets("pour recherche").Range("A2:C" & derligne3).SpecialCells(xlVisible)
  42. resultat.Copy Destination:=Sheets("Rechercher Client").Range("W9")
  43. End Sub


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

Please Help !

Autres pages sur : vba subtotal classeur partage

Meilleure solution

28 Décembre 2016 16:21:52

j'ai trouvé :
  1. Set d1 = CreateObject("Scripting.Dictionary")
  2. a = Range("AV2:AY" & [ba65000].End(xlUp).Row)
  3. j = 0
  4. For i = LBound(a) To UBound(a)
  5. If Not d1.exists(a(i, 2)) Then j = j + 1: d1(a(i, 2)) = j
  6. Next i
  7. Dim b(): ReDim b(1 To d1.Count, 1 To UBound(a, 2))
  8. For ligne = LBound(a) To UBound(a)
  9. p = d1(a(ligne, 2))
  10. b(p, 1) = b(p, 1) + a(ligne, 1)
  11. For k = 2 To 4: b(p, k) = a(ligne, k): Next k
  12. Next ligne
  13. [AR1].Resize(UBound(b), UBound(b, 2)) = b
  14.  
  15. [AT1].Sort Key1:=[AT1], Order1:=xlAscending, Header:=xlYes
partage
a b L Programmation
28 Décembre 2016 18:22:15

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é :D  )
m
0
l