XL 2019 Optimisation de code VBA

[mmaiga]

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..

 

[vgendron]

et la question essentielle: c'est quoi un doublon?
meme nom?
meme couple "Lat / Long" ?

 

[fanch55]

Bonjour à tous,
i7-10700K + 32go ==> entre 16 et 17 sd .

Ce qui me chagrine dans la sub, c'est que si un name a un doublon, ce doublon voit son name sans doublon ?
Sûrement à cause du For j = i + 1 ...

 

[mmaiga]

et la question essentielle: c'est quoi un doublon?
meme nom?
meme couple "Lat / Long" ?

doublon: quand la valeur de la colonne 4 et 5 sont identique donc je le considère comme doublon tout en respectant le calcul de la distance y compris les données de la colonne 1

 

[vgendron]

Colonne 4 = SDS
Colonne 5 = RFDER
tu commences par supprimer la colonne RFDER en faisant [E:E].ClearContents
donc .. forcément.. quelques soient les indices i et j, tablo(i,5) sera toujours égal à tablo (j,5)

donc.. les doublons sont juste sur les SDS ==> tu devrais n'avoir qu'une ligne par numéro de SDS
ce n'est toujours pas ce que fait ta macro...

tant que tu n'aura pas expliqué correctement le cheminement pour trouver un doublon et répondu aux questions qu'on te pose. on va tourner en rond

 

[cp4]

J'ai trouvé les mêmes doublons en colonnes A (comme @vgendron). Donc il faudrait supprimé ces doublons ( ne garder qu'un seul).
Si je comprends bien tu calcules la distance entre chaque points et si la distance est inférieure à 10 km, tu la considères comme doublons.
Autrement dit, tu calcules la distance par exemple entre premier de la liste aux autres points de la liste.
le 2ème point aux suivants de la liste et ainsi de suite.

 

[mmaiga]

Colonne 4 = SDS
Colonne 5 = RFDER
tu commences par supprimer la colonne RFDER en faisant [E:E].ClearContents
donc .. forcément.. quelques soient les indices i et j, tablo(i,5) sera toujours égal à tablo (j,5)

donc.. les doublons sont juste sur les SDS ==> tu devrais n'avoir qu'une ligne par numéro de SDS
ce n'est toujours pas ce que fait ta macro...

tant que tu n'aura pas expliqué correctement le cheminement pour trouver un doublon et répondu aux questions qu'on te pose. on va tourner en rond

Ce code e destiné à calculer les distances entre des points géographiques (latitude et longitude) à partir d'une liste de coordonnées présentes dans une feuille de calcul. Le code utilise la formule de Haversine pour calculer la distance entre deux points géographiques.

En plus du calcul de distance, le code a également pour objectif de rechercher les doublons dans la liste de coordonnées et d'afficher les doublons trouvés, ainsi que leur distance par rapport à l'élément de la liste de coordonnées en cours de traitement. Les doublons sont identifiés en comparant les valeurs des colonnes 4 et 5 de la feuille de calcul.

J'espère être clair

Concernant cette partie

[E:E].ClearContents

Ne tient pas compte normalement c'est F au lieu de E

 

[fanch55]

Colonne 4 = SDS
Colonne 5 = RFDER
tu commences par supprimer la colonne RFDER en faisant [E:E].ClearContents
donc .. forcément.. quelques soient les indices i et j, tablo(i,5) sera toujours égal à tablo (j,5)

donc.. les doublons sont juste sur les SDS ==> tu devrais n'avoir qu'une ligne par numéro de SDS
ce n'est toujours pas ce que fait ta macro...

tant que tu n'aura pas expliqué correctement le cheminement pour trouver un doublon et répondu aux questions qu'on te pose. on va tourner en rond

Les colonnes 4 et 5 ne sont jamais recalculées dans la sub donc toutes sont = 0 .
la condition

 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

ne teste en fait que le d ????

 

[vgendron]

En attendant d'avoir des réponses qui soient cohérentes avec le résultat de ta macro
voici un travail par macro
1) récupère les données de la feuille2
2) effectue un tri sur latitude et longitude croissante
3) met des formules pour calculer les delta Lat et delat Long ainsi que a et d

 

[sylvanu]

Bonjour Mmaiga, Fanch, Vgendron, CP4,
Un essai en PJ en optimisant.
Sur mon PC et votre fichier j'obtient :

Soit près de 4 fois plus rapide.
Je fais le test de vraisemblance non pas en degrés et km mais directement de décimal, ce qui évite bien des calculs inutiles. De plus je double le test plutôt que de faire un OR en pariant que statistiquement on évitera un IF.

 

[fanch55]

Bonjour Mmaiga, Fanch, Vgendron, CP4,

Je fais le test de vraisemblance non pas en degrés et km mais directement de décimal, ce qui évite bien des calculs inutiles. De plus je double le test plutôt que de faire un OR en pariant que statistiquement on évitera un IF.

Salut @sylvanu ,
si B est un doublon de A, A devrait être un doublon de B ?

 

[sylvanu]

si B est un doublon de A, A devrait être un doublon de B ?

C'est ainsi !
Dans le fichier de base c'est traité comme ça. C'est du au For j=i+1 + ubound(tablo)
on ne revient pas en arrière.

 

[mmaiga]

Voici le code modifié, le code fonctionne mais j'aimerais juste améliorer la performance

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
[F:F].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

En attendant d'avoir des réponses qui soient cohérentes avec le résultat de ta macro
voici un travail par macro
1) récupère les données de la feuille2
2) effectue un tri sur latitude et longitude croissante
3) met des formules pour calculer les delta Lat et delat Long ainsi que a et d

Merci infiniment je suis à 16 seconde, actuellement avec le fichier que tu viens de m'envoyer. j'ai essayé avec plus de données avant j'étais à plus de 60 s à l'heure actuelle je suis à 21.5 secondes. Possible d'optimiser d'avantage.

 

[mmaiga]

Voici le code modifié, le code fonctionne mais j'aimerais juste améliorer la performance

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
[F:F].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

Bonjour Mmaiga, Fanch, Vgendron, CP4,
Un essai en PJ en optimisant.
Sur mon PC et votre fichier j'obtient :
Regarde la pièce jointe 1168255
Soit près de 4 fois plus rapide.
Je fais le test de vraisemblance non pas en degrés et km mais directement de décimal, ce qui évite bien des calculs inutiles. De plus je double le test plutôt que de faire un OR en pariant que statistiquement on évitera un IF.

Merci infiniment je suis à 16 seconde, actuellement avec le fichier que tu viens de m'envoyer. j'ai essayé avec plus de données avant j'étais à plus de 60 s à l'heure actuelle je suis à 21.5 secondes. Possible d'optimiser d'avantage.

 

[sylvanu]

Voir post #4 de CP4 :

Pour éditer un code facilement lisible utilise l'icône </> de la barre de menu de la discussion.

Il est bon de lire ce que les contributeurs vous disent.

Quand à optimiser plus, à voir.

 

[vgendron]

bah moi.. je reste sur ma faim..
des questions posées, mais jamais de réponse apportée par le demandeur
et je n'ai toujours pas compris ce qu'était un doublon....

je passe mon tour