Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Optimisation de code VBA

M

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
Trier par date Trier par votes

fanch55

XLDnaute Barbatruc
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 ...
 
Dernière édition:
Vote positif 0 Vote négatif

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif

cp4

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
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
Cliquez pour agrandir...
Ne tient pas compte normalement c'est F au lieu de E
 
Vote positif 0 Vote négatif

fanch55

XLDnaute Barbatruc
Les colonnes 4 et 5 ne sont jamais recalculées dans la sub donc toutes sont = 0 .
la condition
VB: 
 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 ????
 
Vote positif 0 Vote négatif

vgendron

XLDnaute Barbatruc
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
 

Pièces jointes

  • Classeur3.xlsm
    665.4 KB · Affichages: 3
Vote positif 0 Vote négatif

sylvanu

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • Classeur3 (2).xlsm
    685.3 KB · Affichages: 4
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
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
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.
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
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
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.
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

M
  • Question
XL 2019 Optimisation code VBA
Réponses
11
Affichages
881
mmaiga
M
  • Question
XL 2010 Code de l'IA à corriger
2 3
Réponses
33
Affichages
2 K
cathodique
  • Question
Autres la fonction similaire
Réponses
11
Affichages
432
patricktoulon
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
372
CathyLD
C
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
1 K
Dranreb
E
  • Question
Microsoft 365 Listbox avec plus de 10 colonnes
Réponses
6
Affichages
444
Excellearning
E
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
398
Phil69970
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
2 K
saidoush
S
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…