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
cp4

cp4

XLDnaute Barbatruc
mmaiga à dit:
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..
Cliquez pour agrandir...
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+
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
cp4 à dit:
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+
Cliquez pour agrandir...
Merci pour ce retour rapide. Par contre, je ne sais pas utilisé un dictionnaire? Vous pouvez m'aider svp?
 
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
mmaiga à dit:
Merci pour ce retour rapide. Par contre, je ne sais pas utilisé un dictionnaire? Vous pouvez m'aider svp?
Cliquez pour agrandir...
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)
 
Vote positif 0 Vote négatif
vgendron

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??
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
cp4 à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
vgendron à dit:
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??
Cliquez pour agrandir...
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)
 
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
mmaiga à dit:
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
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
mmaiga à dit:
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)
Cliquez pour agrandir...
Ce qui est très limpide pour toi, ne l'est pas forcément pour les contributeurs.
Je n'ai rien compris.
 
Vote positif 0 Vote négatif
vgendron

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é..??
 
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
Juste pour info, mon pc dell windows7 excel2010, i5, 4Go de ram. temps avec ton code.
1681471790824.png
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
cp4 à dit:
Ce qui est très limpide pour toi, ne l'est pas forcément pour les contributeurs.
Je n'ai rien compris.
Cliquez pour agrandir...
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é
 
Vote positif 0 Vote négatif
vgendron

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??
 
Vote positif 0 Vote négatif
M

mmaiga

XLDnaute Nouveau
vgendron à dit:
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??
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2019 Optimisation code VBA
Réponses
11
Affichages
880
mmaiga
M
cathodique
  • Question
XL 2010 Code de l'IA à corriger
2 3
Réponses
33
Affichages
2 K
cathodique
cathodique
patricktoulon
  • Question
Autres la fonction similaire
Réponses
11
Affichages
432
patricktoulon
patricktoulon
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
136
patricktoulon
patricktoulon
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
372
CathyLD
C
lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
526
AtTheOne
AtTheOne
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
1 K
Dranreb
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
Phil69970
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
2 K
saidoush
S

Membres actuellement en ligne

15 membres et 128 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 089
Messages
2 116 094
Membres
112 658
dernier inscrit
doro 76