Need a little help in vba (besoin d'aide sur un code VBA sans pivot table ni sumprod)

[gosselien]

Bonjour,

j'essaye en vain de faire un code VBA pour totaliser des centaines de lignes pour différentes personnes et par jour; les explications sont dans le fichier.
J'y arrive presque, mais par pour les totaux et la répartition par personne en bas du tableau résumé qui commence en colonne N2

Merci de votre aide et de mettre des commentaires dans les lignes que vous ajoutez pour que je comprenne votre code

Je veux faire ça sans sommeprod ni tableau croisé...car j'aimerais comprendre et maitriser un peu les tableaux.

Le fichier est ici: https://www.dropbox.com/s/k0n4wza9fvshwww/consolidation with vba.xlsm?dl=0

Merci !!!!

Patrick

 

[Anthony47]

Mais vous ne avez pas clarifie' une question: "est il valide la table et la description fournie dans le fichier de l'échantillon [premier message] ou la description faite dans le dernier message? Dans ce second cas, il aurait besoin d'un fichier de données aligné"

bye

 

[gosselien]

Hello Anthony,

THIS is the good version to help me for understanding VBA and dictionnary

2 tableaux à créer en dessous ou dans autre onglets

https://www.dropbox.com/s/a5g4w40luxuxg0d/consolidation with vba.xlsm?dl=0

Merci


Patrick

 

[Anthony47]

Sur la base de ce que je compris je propose une macro pour calculer les deux résumés dont vous avez parlé.
Le code est le suivant:

Sub recaps()
'See http://www.mrexcel.com/forum/questions-other-languages/841535-need-little-help-visual-basic-applications-besoin-daide-sur-un-code-visual-basic-applications-sans-pivot-table-ni-sumprod-2.html
Dim wArr, mySumm As Worksheet, I As Long, hArr, myMatch, myStart As String
Dim res1Arr() As Single, res2Arr() As Single, myTim As Single, myDataSh As String
Dim LBwArrV As Long, UBwArrV As Long, LBwArrH As Long, UBwArrH As Long
Dim PersCnt As Long, Pers2Cnt As Long, J As Long
'
myDataSh = "Feuil1"                         '<<< 1 See Message
myStart = "N1"                              '<<< 2 See Message
Set mySumm = Sheets("RECAP")                '<<< 3 !! SEE MESSAGE !!
'
myTim = Timer
Sheets(myDataSh).Activate
wArr = Range(Range(myStart).End(xlDown), Range(myStart).End(xlToRight)).Value     'Data to array
mySumm.Cells.ClearContents                                                  'Clear Summary sheet
hArr = Application.WorksheetFunction.Index(wArr, 1, 0)                      'Get Data header
LBwArrV = LBound(wArr, 1): UBwArrV = UBound(wArr, 1)
LBwArrH = LBound(wArr, 2): UBwArrH = UBound(wArr, 2)
'
mySumm.Range("A1").Resize(1, UBound(wArr, 2)).Value = hArr                  'Fill headers in Summary
ReDim res1Arr(LBound(wArr, 1) To UBound(wArr, 1), LBound(wArr, 2) To UBound(wArr, 2))   'redim results1 array
ReDim res2Arr(LBound(wArr, 1) To UBound(wArr, 1), LBound(wArr, 2) To UBound(wArr, 2))   'redim results2 array
'
'Calculate first Summary (Personne / Date):
For I = LBwArrV + 1 To UBwArrV
    'First Summary: Current name already in Summary?
    myMatch = Application.Match(wArr(I, 1), mySumm.Range("A1").Resize(UBwArrV, 1), False)
    If IsError(myMatch) Then
        mySumm.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = wArr(I, 1)     'Missing, add it
        myMatch = PersCnt + 2: PersCnt = PersCnt + 1
    End If
    For J = LBwArrH + 2 To UBwArrH                                          'Sum activities for each day
        res1Arr(myMatch - 1, J - 2) = res1Arr(myMatch - 1, J - 2) + wArr(I, J)
    Next J
Next I
'
'Reloop for second Summary (Personne & Activité / Date):
mySumm.Range("A1").Offset(PersCnt + 5, 0).Resize(1, UBound(wArr, 2)).Value = hArr               'Fill headers in Summary
For I = LBwArrV + 1 To UBwArrV
    'Second Summary: Current name/Activity already in Summary?
    myMatch = Application.Match(wArr(I, 1) & Chr(124) & wArr(I, 2), _
        mySumm.Range("A1").Offset(PersCnt + 5, 0).Resize(UBwArrV, 1), False)
    If IsError(myMatch) Then
        mySumm.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
            wArr(I, 1) & Chr(124) & wArr(I, 2)                                                  'Missing, add it
        myMatch = Pers2Cnt + 2: Pers2Cnt = Pers2Cnt + 1
    End If
    For J = LBwArrH + 2 To UBwArrH                                          'Sum activities for each day
        res2Arr(myMatch - 1, J - 2) = res2Arr(myMatch - 1, J - 2) + wArr(I, J)
    Next J
Next I
'Write results on Output Sheet
mySumm.Range("C2").Resize(PersCnt, UBwArrH - 2).Value = res1Arr                         'Write first Summary
mySumm.Range("C2").Offset(PersCnt + 5, 0).Resize(Pers2Cnt, UBwArrH - 2).Value = res2Arr 'Write second Summary
'Split Personne | Activité:
mySumm.Range("A2").Offset(PersCnt + 5, 0).Resize(Pers2Cnt, 1).TextToColumns _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'
mySumm.Cells.EntireColumn.AutoFit
'
MsgBox ("Traitement terminé, durée " & Format(Timer - myTim, "0.00") & " Secondes")
End Sub

Les instructions marquées "<<<" doivent être personnalisés avec:
- le nom de la fiche contenant la base de données
- la cellule initiales (en haut à gauche) des données, y compris l'en-tête
- le nom de la fiche sur laquelle nous allons créer les résultats; tout le contenu de cette fiche est effacé de la macro sans préavis.

Désolé de vous décevoir, mais je ne ai pas utiliser un dictionnaire, mais une matrice pour copier la base de données initiales et d'autres matrices pour le calcul des deux résumés. Je pourrais utiliser le dictionnaire pour calculer les valeurs uniques, mais on utilisant le feuille de calcul et la fonction Match (EQUIV?) est globalement plus plus rapide (le Dictionnaire pourrait être plus rapide après 20-40 000 valeurs)
Pour une description de l' objet Dictionary: https://msdn.microsoft.com/fr-fr/library/x4k5wbx4.aspx

Je espère que que ce que je propose, ce est de quelque utilité.

Bye

 

[gosselien]

Merci !! Je regarde çà ce week end

Many Thanks


Patrick