Excel VBA cherche à améliorer ce code

Bonjour à tous,

Je me présente

Je fais un peu de développement Excel pour un club d'aviron , en Excel vba je bidouille mas pas efficacement.

d'où mon appel à l'aide voili voila.

Le but de cette procédure est d'extraire par nom les nom sur les colonnes G à N et de faire le total des KM par nom

de le mettre sur une feuille préalablement effacée et de trier le résultat

Mon problèmes c'est qu'avec des millier de lignes ce prend beaucoup de temps en fonction du PC.

ma procédure de trie est elle efficace?....

Merci par avance

Robert

Private Sub KmRameur_Click()
Dim Mess As String
Mess = ""
Dim Finligne As Integer
Dim Findonne As Integer
Dim A1 As String
Dim A2 As String
Dim dt As Integer
Dim x As Integer
Dim name As String
Dim KM As Long
Dim f2 As Integer
Dim xw As Integer
Dim Tkm As Integer
f2 = 1
Feuil5.Visible = True
Feuil5.Select
Feuil5.Cells.Clear
Application.Cursor = xlWait
Finligne = Feuil1.Cells(Rows.Count, 3).End(xlUp).Row
Findonne = Feuil2.Cells(Rows.Count, 1).End(xlUp).Row

For xw = 2 To Finligne
'Feuil1.Select
KM = 0
Tkm = 0
name = Feuil1.Cells(xw, 3)
If name = "" Then
Exit For
End If
For x = 2 To Findonne
DoEvents
A2 = Right(Feuil2.Cells(x, 1), 4) ' date

dt = Val(A2) ' date formt nombre
If dt = dta.Value Then

DoEvents
If Feuil2.Cells(x, 7) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 8) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 9) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 10) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 11) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 12) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If

If Feuil2.Cells(x, 13) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
If Feuil2.Cells(x, 14) = name Then
KM = KM + Val(Feuil2.Cells(x, 5))

End If
End If
Next x
Feuil5.Cells(f2, 1) = name
Feuil5.Cells(f2, 2) = KM

f2 = f2 + 1
DoEvents
Next xw
Finligne = Feuil5.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:B300").Select

    Feuil5.Sort.SortFields.Clear
   Feuil5.Sort.SortFields.Add2 Key:=Range("B1:B46") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With Feuil5.Sort
        .SetRange Range("A1:B300")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'KM1.ColumnCount = 2
    For x = 1 To Finligne
 name = Feuil5.Cells(x, 1)
KM = Feuil5.Cells(x, 2)
Tkm = Tkm + KM
   KM1.listKM.AddItem
   KM1.listKM.List(x - 1, 0) = x
   KM1.listKM.List(x - 1, 1) = name
   KM1.listKM.List(x - 1, 2) = KM
    Next x
Application.Cursor = xlDefault
KM1.Label1.Caption = Tkm

KM1.Show

Feuil5.Visible = False
End Sub

bonjour RBO82000,

avec un dictionaire

Sub Totaux()
     Dim dict, aA, i, j
     Set dict = CreateObject("scripting.dictionary")
     dict.comparemode = vbTextCompare

     aA = Sheets("Feuil1").Range("A1").CurrentRegion.Value2
     For i = 2 To UBound(aA)                 'boucler les lignes sauf entêtes
          If Len(aA(i, 5)) > 0 And IsNumeric(aA(i, 5)) Then
               For j = 7 To UBound(aA, 2)    'boucler les colonnes à partir du nom1
                    If Len(aA(i, j)) > 0 Then dict(aA(i, j)) = dict(aA(i, j)) + aA(i, 5)     'cumul des kms
               Next
          End If
     Next

     With Sheets.Add(after:=Sheets("feuil1"))     'nouvelle feuille
          With .Range("A1:B1")
               .Value = Array("nom", "KM")
               With .Offset(1).Resize(dict.Count)
                    .Columns(1).Value = Application.Transpose(dict.keys)
                    .Columns(2).Value = Application.Transpose(dict.items)
                    .Columns(2).NumberFormat = "#,##0.00"
                    .Sort .Range("B1"), xlDescending, Header:=xlNo
                    .EntireColumn.AutoFit
               End With
          End With
     End With

End Sub

Bonjour

Super ça fonctionne très bien

Merci du coup de main

Il faut que je creuse cette methode

Bonjour

je n'arrive pas en modifient le code à faire une recherche par anné e(ex:2024) - nom - km

Une solution?

Bonjour à tous,

Sur Office365 vous pouvez aussi tirer profit des fonctions de type "TCD". Ainsi avec GROUPBY, vous pouvez sommer vos km par date. Attention par contre, dans le fichier joint j'avais des kilomètres avec un "." au lieu de ",", qui fait que ces valeurs sont considérées comme texte par Excel. A corriger.

En gros pour cette question, pas besoin de VBA 😉

=GROUPBY(A1:A483;E1:E483;SUM;3)

Bonjour

Après corrections des textes au milieu des kms (ç remplacé par 9, ; remplacé par , et m remplacé par rien) en quelques clics on décroise par PowerQuery puis on restitue la requête dans un TCD

J'ai jouté un filtre possible par mois

Il suffit d'actualiser le TCD quand la source évolue que ce soit en nombre de lignes ou de colonnes

NB: je n'ai pas conservé les lignes sans aucun nom mais on peut le faire. On peut trier le TCD par kms si c'est ce qui est souhaité (demande imprécise)

On peut modifier le regoupement de dates dans le TCD pour garder 3 niveau Année, Mois, Jour

RE

saboh12617 a écrit :

Bonjour à tous,

Sur Office365 vous pouvez aussi tirer profit des fonctions de type "TCD". Ainsi avec GROUPBY, vous pouvez sommer vos km par date. Attention par contre, dans le fichier joint j'avais des kilomètres avec un "." au lieu de ",", qui fait que ces valeurs sont considérées comme texte par Excel. A corriger.

En gros pour cette question, pas besoin de VBA 😉

=GROUPBY(A1:A483;E1:E483;SUM;3)

Oui mais c'est par date et non par nom

re & bonjour 78chis et Saboh12617,

Bonjour à tous

Merci beaucoup pour votre aide précieuse j'ai fini d'adapter le code à mon fichier excel avec une Userform

Tout fonctionne sauf

les bugs qu'ils vont bien me trouver ces petit!!!!

En tout cas j'ai beaucoup appris de vos différentes approchent à mon problème

Merci encore