XL 2019 Optimisation de code VBA

mmaiga

XLDnaute Nouveau
Bonjour,

Je viens vers vous pour pouvoir m'aider concernant l'optimisation de ce code. le code fonctionne mais le temps de l'execution n'est pas à mon goût ( 61 secondes).
Pouvez-vous m'aider à améliorer ce code ?

Je vous joins le fichier Excel. et j'aimerais que les données de la colonne E soient affichées.
Etant donné que le fichier est lourd, j'ai supprimé des données.

Code

Option Explicit

Sub Calculer_test()

' Tranfert pour TEST
Sheets("Feuil1").Range("A1:F13842") = Sheets("Feuil2").Range("A1:F13842").Value
' --------------------------------------------

' Options de calcul

Dim CalcMode As Long
CalcMode = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False

'---------------------------------------------------

Dim T0: T0 = Timer
Dim lastRow As Long, lat1 As Double, lat2 As Double, lon1 As Double, lon2 As Double, R As Double
Dim dLat As Double, dLon As Double, a As Double, c As Double, d As Double, i As Long, j As Long, k As Long, doublon As Boolean
Dim tablo, T, Cte ' Tableaux de transfert, T étant le résultat
R = 6371 ' Rayon de la terre en km
Cte = Application.Pi / 180 ' PI/180, constante calculée une seule fois au début
lastRow = Range("B" & Rows.Count).End(xlUp).Row
[E:E].ClearContents
tablo = Range("A1:E" & lastRow)
ReDim T(1 To UBound(tablo)): T(1) = "Doublons"
For i = 2 To UBound(tablo)
'Application.StatusBar = "Ligne traitée : " & i & " sur " & lastRow ' A valider si on veut le suivi dans le statusbar
lat1 = tablo(i, 2) * Cte 'conversion de degrés à radians
lon1 = tablo(i, 3) * Cte
doublon = False 'initialisation du drapeau de doublon
For j = i + 1 To UBound(tablo)
If i <> j Then 'ne compare pas avec soi-même
lat2 = tablo(j, 2) * Cte
lon2 = tablo(j, 3) * Cte
dLat = lat2 - lat1
dLon = lon2 - lon1
If Abs(lat1 - lat2) / Cte < 0.1 Or Abs(lon1 - lon2) / Cte < 0.1 Then
a = Sin(dLat / 2) * Sin(dLat / 2) + Cos(lat1) * Cos(lat2) * Sin(dLon / 2) * Sin(dLon / 2)
d = 2 * R * Application.Asin(Sqr(a))
If d < 10 And tablo(i, 4) = tablo(j, 4) And tablo(i, 5) = tablo(j, 5) Then 'enregistre si la distance est inférieure à 10 km et s'il y a un doublon dans la colonne D
'T(i) = T(i) & " " & tablo(j, 1)
T(i) = T(i) & " " & tablo(j, 1) & "(" & j & ": " & Format(d, "0.00") & " km)"
doublon = True 'marque le drapeau de doublon
End If
End If
End If
Next j
If Not doublon Then T(i) = "Aucun doublon trouvé" 'si aucun doublon n'est trouvé, enregistre "Aucun doublon trouvé"
Next i
[F1].Resize(UBound(T), 1).Value = Application.Transpose(T)
Application.StatusBar = ""


'---------------------------------

Application.Calculation = CalcMode
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True


[K2] = Timer - T0
End Sub





Merci d'avance..
 

Pièces jointes

  • Classeur3.xlsm
    968.9 KB · Affichages: 19

cp4

XLDnaute Barbatruc
Bonjour,

Je viens vers vous pour pouvoir m'aider concernant l'optimisation de ce code. le code fonctionne mais le temps de l'execution n'est pas à mon goût ( 61 secondes).
Pouvez-vous m'aider à améliorer ce code ?

Je vous joins le fichier Excel. et j'aimerais que les données de la colonne E soient affichées.
Etant donné que le fichier est lourd, j'ai supprimé des données.

Code

Option Explicit

Sub Calculer_test()

' Tranfert pour TEST
Sheets("Feuil1").Range("A1:F13842") = Sheets("Feuil2").Range("A1:F13842").Value
' --------------------------------------------

' Options de calcul

Dim CalcMode As Long
CalcMode = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False

'---------------------------------------------------

Dim T0: T0 = Timer
Dim lastRow As Long, lat1 As Double, lat2 As Double, lon1 As Double, lon2 As Double, R As Double
Dim dLat As Double, dLon As Double, a As Double, c As Double, d As Double, i As Long, j As Long, k As Long, doublon As Boolean
Dim tablo, T, Cte ' Tableaux de transfert, T étant le résultat
R = 6371 ' Rayon de la terre en km
Cte = Application.Pi / 180 ' PI/180, constante calculée une seule fois au début
lastRow = Range("B" & Rows.Count).End(xlUp).Row
[E:E].ClearContents
tablo = Range("A1:E" & lastRow)
ReDim T(1 To UBound(tablo)): T(1) = "Doublons"
For i = 2 To UBound(tablo)
'Application.StatusBar = "Ligne traitée : " & i & " sur " & lastRow ' A valider si on veut le suivi dans le statusbar
lat1 = tablo(i, 2) * Cte 'conversion de degrés à radians
lon1 = tablo(i, 3) * Cte
doublon = False 'initialisation du drapeau de doublon
For j = i + 1 To UBound(tablo)
If i <> j Then 'ne compare pas avec soi-même
lat2 = tablo(j, 2) * Cte
lon2 = tablo(j, 3) * Cte
dLat = lat2 - lat1
dLon = lon2 - lon1
If Abs(lat1 - lat2) / Cte < 0.1 Or Abs(lon1 - lon2) / Cte < 0.1 Then
a = Sin(dLat / 2) * Sin(dLat / 2) + Cos(lat1) * Cos(lat2) * Sin(dLon / 2) * Sin(dLon / 2)
d = 2 * R * Application.Asin(Sqr(a))
If d < 10 And tablo(i, 4) = tablo(j, 4) And tablo(i, 5) = tablo(j, 5) Then 'enregistre si la distance est inférieure à 10 km et s'il y a un doublon dans la colonne D
'T(i) = T(i) & " " & tablo(j, 1)
T(i) = T(i) & " " & tablo(j, 1) & "(" & j & ": " & Format(d, "0.00") & " km)"
doublon = True 'marque le drapeau de doublon
End If
End If
End If
Next j
If Not doublon Then T(i) = "Aucun doublon trouvé" 'si aucun doublon n'est trouvé, enregistre "Aucun doublon trouvé"
Next i
[F1].Resize(UBound(T), 1).Value = Application.Transpose(T)
Application.StatusBar = ""


'---------------------------------

Application.Calculation = CalcMode
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True


[K2] = Timer - T0
End Sub





Merci d'avance..
Bonjour,

C'est normal que ta macro est long, tu as des boucles imbriquées.
Pourquoi ne pas utiliser une colonne intermédiaire pour tes calculs.
Puis cibler les doublons en utilisant un dictionnaire (objet Dictionary).
Pour éditer un code facilement lisible utilise l'icône </> de la barre de menu de la discussion.
A+
 

mmaiga

XLDnaute Nouveau
Bonjour,

C'est normal que ta macro est long, tu as des boucles imbriquées.
Pourquoi ne pas utiliser une colonne intermédiaire pour tes calculs.
Puis cibler les doublons en utilisant un dictionnaire (objet Dictionary).
Pour éditer un code facilement lisible utilise l'icône </> de la barre de menu de la discussion.
A+
Merci pour ce retour rapide. Par contre, je ne sais pas utilisé un dictionnaire? Vous pouvez m'aider svp?
 

cp4

XLDnaute Barbatruc
Merci pour ce retour rapide. Par contre, je ne sais pas utilisé un dictionnaire? Vous pouvez m'aider svp?
Si ce n'est pas moi, il y aura surement une autre personne.
Avec ton code j'ai pu gagner 7sec. si ça t’intéresses
VB:
For i = 2 To UBound(tablo)
      'Application.StatusBar = "Ligne traitée : " & i & " sur " & lastRow  ' A valider si on veut le suivi dans le statusbar
'      lat1 = tablo(i, 2) * Cte    'conversion de degrés à radians
'      lon1 = tablo(i, 3) * Cte
      doublon = False             'initialisation du drapeau de doublon
      For j = i + 1 To UBound(tablo)
         If i <> j Then          'ne compare pas avec soi-même
            '                    lat2 = tablo(j, 2) * Cte
            '                    lon2 = tablo(j, 3) * Cte
            '                    dLat = lat2 - lat1
            '                    dLon = lon2 - lon1
            '--------------------------------------------
            lat2 = tablo(j, 2) * Cte
            lon2 = tablo(j, 3) * Cte
            dLat = tablo(j, 2) * Cte - tablo(i, 2) * Cte
            dLon = tablo(j, 3) * Cte - tablo(i, 3) * Cte

Peux-tu nous expliquer tes calculs (pas la comparaison) par ligne.

édit: une discussion concernant le dictionnaire (fait une recherche sur google: JB VBA, tu ne seras pas déçu)
 

vgendron

XLDnaute Barbatruc
Hello

si je peux me permettre une remarque ou deux
1) chez moi, le code tel quel s'execute en 34 secondes ==> je suppose donc que les performances du PC ont leur importance (mon PC n'est pourtant pas tout jeune)
2) la ligne de code "if i<>j then 'ne compare pas avec soi -même
me semble inutile puisque juste avant tu fais un for j=i+1
ca fait donc déjà un if imbriqué de moins (et hop. 4s de gagnées en plus)
3) je n'ai pas bien compris ce qui faisait les doublons..

les "Name" sont ils uniques?
deux couples "Latitude / Longitude" peuvent devenir deux doublons suite au calcul??
 

mmaiga

XLDnaute Nouveau
Si ce n'est pas moi, il y aura surement une autre personne.
Avec ton code j'ai pu gagner 7sec. si ça t’intéresses
VB:
For i = 2 To UBound(tablo)
      'Application.StatusBar = "Ligne traitée : " & i & " sur " & lastRow  ' A valider si on veut le suivi dans le statusbar
'      lat1 = tablo(i, 2) * Cte    'conversion de degrés à radians
'      lon1 = tablo(i, 3) * Cte
      doublon = False             'initialisation du drapeau de doublon
      For j = i + 1 To UBound(tablo)
         If i <> j Then          'ne compare pas avec soi-même
            '                    lat2 = tablo(j, 2) * Cte
            '                    lon2 = tablo(j, 3) * Cte
            '                    dLat = lat2 - lat1
            '                    dLon = lon2 - lon1
            '--------------------------------------------
            lat2 = tablo(j, 2) * Cte
            lon2 = tablo(j, 3) * Cte
            dLat = tablo(j, 2) * Cte - tablo(i, 2) * Cte
            dLon = tablo(j, 3) * Cte - tablo(i, 3) * Cte


Peux-tu nous expliquer tes calculs (pas la comparaison) par ligne.
Oui, ça m'intéresse si j'arrive à améliorer. Le but de mon code est de trouver un doublons lors des calculs de la distance dans un rayon de 10 km en faisant une comparaison entre les données de la colonne D et E. J'ai essayé ton code, mais le résultat n'est pas correct. c'est pas ce que j'attends
 

mmaiga

XLDnaute Nouveau
Hello

si je peux me permettre une remarque ou deux
1) chez moi, le code tel quel s'execute en 34 secondes ==> je suppose donc que les performances du PC ont leur importance (mon PC n'est pourtant pas tout jeune)
2) la ligne de code "if i<>j then 'ne compare pas avec soi -même
me semble inutile puisque juste avant tu fais un for j=i+1
ca fait donc déjà un if imbriqué de moins (et hop. 4s de gagnées en plus)
3) je n'ai pas bien compris ce qui faisait les doublons..

les "Name" sont ils uniques?
deux couples "Latitude / Longitude" peuvent devenir deux doublons suite au calcul??
J'ai la marque Lenovo (Lenovo Thinkpad t14 i5), je ne pense pas que mon PC soit moins performant, voici un exemple de ce que je veux. le but est de calculer dans un rayon de 10 km en faisant une comparaison entre les 2 colonnes: dfd et fgf.

nameLatitudeLongitudedfdfgf
50553_001-72
48.573789​
-1.334829​
0​
0​
50410_010-71
48.5190226​
-1.4296076​
0​
0​

Le résultat attendu

nameLatitudeLongitudedfdfgfDoublons
50553_001-72
48.573789​
-1.334829​
0​
0​
50410_010-71(14: 9.26 km)
 

cp4

XLDnaute Barbatruc
Oui, ça m'intéresse si j'arrive à améliorer. Le but de mon code est de trouver un doublons lors des calculs de la distance dans un rayon de 10 km en faisant une comparaison entre les données de la colonne D et E. J'ai essayé ton code, mais le résultat n'est pas correct. c'est pas ce que j'attends
Si on ne comprend pas parfaitement les tenants et aboutissants de la demande, difficile de répondre correctement.
Tout comme @vgendron au post#5, je ne t'ai suggéré qu'une idée pour réduire le temps d’exécution de ta macro.
Il y a surement une autre approche pour résoudre ton problème. D'où ma précédente suggestion de passer par une colonne intermédiaire de calcul, puis travailler uniquement sur cette colonne.
 
Dernière édition:

cp4

XLDnaute Barbatruc
J'ai la marque Lenovo (Lenovo Thinkpad t14 i5), je ne pense pas que mon PC soit moins performant, voici un exemple de ce que je veux. le but est de calculer dans un rayon de 10 km en faisant une comparaison entre les 2 colonnes: dfd et fgf.

nameLatitudeLongitudedfdfgf
50553_001-72
48.573789​
-1.334829​
0​
0​
50410_010-71
48.5190226​
-1.4296076​
0​
0​

Le résultat attendu

nameLatitudeLongitudedfdfgfDoublons
50553_001-72
48.573789​
-1.334829​
0​
0​
50410_010-71(14: 9.26 km)
Ce qui est très limpide pour toi, ne l'est pas forcément pour les contributeurs.
Je n'ai rien compris.
 

vgendron

XLDnaute Barbatruc
Si je comprend bien.. deux points séparés de moins de 10 km sont considérés comme des doublons..

1) il faudrait peut etre commencer par trier le tableau mais.. dans ce cas.. si les points sont tous distants de 9km.. bah.. ils seront tous doublon....

2) de ce que j'ai vu, il y a des couples "Lat/Long" en doublon==> pas besoin de faire le moindre calcul de distance

3) l'ordre des points dans ton tableau est il un ordre de saisie qui correspond à quelque chose de particulier?
dans ce cas, on pourrait interpréter que si le passage d'un point à l'autre est <10km, on a un doublon
mais plus tard. rien n'empeche de revenir à -10km d'un point déjà testé..??
 

cp4

XLDnaute Barbatruc
Juste pour info, mon pc dell windows7 excel2010, i5, 4Go de ram. temps avec ton code.
1681471790824.png
 

mmaiga

XLDnaute Nouveau
Ce qui est très limpide pour toi, ne l'est pas forcément pour les contributeurs.
Je n'ai rien compris.
Les valeurs à comparer se trouvent dans la colonne 1 sauf qu’il a une condition que j’ai ajouté pour dire si la valeur de la colonne 4 est égale à la valeur de la colonne 5 avec une distance < 10 Km de m'afficher dans la colonne 6 les données de la colonne 1 qui respecte cette condition sinon mettre aucun doublon trouvé
 

vgendron

XLDnaute Barbatruc
y a quand meme quelque chose qui cloche

Dans la colonne 1: il s'agit des noms: il n'y en a QUE 3 en doublons (50129_014-71, 62041_004-71 et 62041_004_73)
pourtant ton code remonte beaucoup plus de doublons..

une de mes questions: les noms sont ils uniques ??
condition : si valeur colonne 4 (SDS) = valeur colonne 5 (Doublons) ===> ??? comment une valeur peut elle être égale à du texte??
 

mmaiga

XLDnaute Nouveau
y a quand meme quelque chose qui cloche

Dans la colonne 1: il s'agit des noms: il n'y en a QUE 3 en doublons (50129_014-71, 62041_004-71 et 62041_004_73)
pourtant ton code remonte beaucoup plus de doublons..

une de mes questions: les noms sont ils uniques ??
condition : si valeur colonne 4 (SDS) = valeur colonne 5 (Doublons) ===> ??? comment une valeur peut elle être égale à du texte??
La colonne 4 et 5 c'est des chiffres, colonne 1 est un texte et les données seront affichés dans la colonne 6 en texte.
 

Discussions similaires

Réponses
0
Affichages
83