Re : Somme valeurs associes/ category
Re Mireille,
Peut tu me dire si avec cette base de donnees tres simple, tu arrives a appliquer cette macro...ou quel est le loup qui se cache dans la formule?
Le fichier de rapport est trop grand alors j'ai pense que tu pouvais peut etre faire un copier colle de la macro dans ton propre repertoire...en fait j'ai mon probleme de Type loss#1,2 qui refait son apparition...ca doit seulement etre un chiffre ou une lettre mais je ne vois pas...
Sub Alan()
Dim Feuille As Worksheet
Dim T
T = Timer()
Dim chemin As String
chemin = ActiveWorkbook.Path & "\"
Dim Fichier
Fichier = ActiveWorkbook.Name
Dim FicBase
FicBase = "Base Alan.xls"
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("TMP").Range("K1").Value = Sheets("TMP").Range("K1").Value + 1
'Effacement
Sheets("TMP").Select
Range("A3:H5000").ClearContents
Workbooks.Open chemin & FicBase
'Boucle pour chaque onglet sauf TMP et Rapport
'Sélectionne les données à copier et les placent les unes en dessous des autres dans l'onglet TMP
'La ligne date d'un coté et les données de l'autre, à cause du blanc qui crée un décalage...
'Mets des x pour remplir les éventuels vides sur les deux 1ères colonnes
Windows(FicBase).Activate
For Each Feuille In ActiveWorkbook.Worksheets
Feuille.Range("A3:H3").Copy
Windows(Fichier).Activate
With Sheets("TMP")
.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
Feuille.Range("A28:H31").Copy
.Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
Feuille.Range("A32:H35").Copy
.Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
Feuille.Range("A36:H39").Copy
.Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
Feuille.Range("A40:H43").Copy
.Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues, SkipBlanks:=False, Transpose:=True
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "x"
ActiveCell.Offset(0, 1).Formula = "x"
End With
Windows(FicBase).Activate
Next Feuille
'Ferme le fichier Base
Windows(FicBase).Activate
ActiveWorkbook.Close
' Se place sur la dernière ligne de l'onglet TMP
Windows(Fichier).Activate
Sheets("Tmp").Range("A65536").End(xlUp).Select
'Supprime les lignes inutiles de libellés et x en remontant ligne par ligne
Do While ActiveCell.Row > 2
If ActiveCell.Value = "" Or ActiveCell.Value = "x" Then
ActiveCell.EntireRow.Delete Shift:=xlUp
End If
Selection.Offset(-1, 0).Select
Loop
' copie les formules Trimestre mois semaine
Range("F1:H1").Copy
Range("F3:h2000").PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Actualise le(s) tableau(x) croisé(s) dynamique(s)
ActiveWorkbook.Names.Add Name:="Date", RefersToR1C1:="=TMP!R3C1:R2000C1"
ActiveWorkbook.Names.Add Name:="Description", RefersToR1C1:="=TMP!R3C4:R2000C4"
ActiveWorkbook.Names.Add Name:="Loss", RefersToR1C1:="=TMP!R3C5:R2000C5"
ActiveWorkbook.Names.Add Name:="SubCategory", RefersToR1C1:="=TMP!R3C3:R2000C3"
ActiveWorkbook.Names.Add Name:="TypeLoss", RefersToR1C1:="=TMP!R3C2:R2000C2"
ActiveWorkbook.Names.Add Name:="BaseTCD", RefersToR1C1:="=OFFSET(TMP!R2C1:R2000C8,,,COUNTA(TMP!R2C1:R2000C1))"
Call TCD
ActiveWorkbook.RefreshAll
Sheets("Rapport").Select
Range("S5").FormulaArray = _
"=INDEX(TMP!C2,MIN(IF(TMP!R3C2:R2000C2<>"""",IF(COUNTIF(R4C:R[-1]C,TMP!R3C2:R2000C2)=0,ROW(TMP!R3C2:R2000C2)))))&"""""
Range("S5:S34").FillDown
Range("V5").FormulaArray = _
"=INDEX(TMP!C3,MIN(IF(TMP!R3C3:R2000C3<>"""",IF(COUNTIF(R4C:R[-1]C,TMP!R3C3:R2000C3)=0,ROW(TMP!R3C3:R2000C3)))))&"""""
Range("V5:V34").FillDown
Range("Y5").FormulaArray = _
"=INDEX(TMP!C4,MIN(IF(TMP!R3C4:R2000C4<>"""",IF(COUNTIF(R4C:R[-1]C,TMP!R3C4:R2000C4)=0,ROW(TMP!R3C4:R2000C4)))))&"""""
Range("Y5:Y34").FillDown
Range("N2").Select
MsgBox "Extraction réalisée en " & Format(Timer() - T, 0) & " secondes", , "Mth et JCGL pour Alan ;-)"
End Sub
Merci de la tester et encore desole...