XL 2013 code temps exécution long

[Usine à gaz]

Bonjour à toutes et à tous,
Tout d'abord, je vous souhaite un très bon WE 😉

Je me permets de revenir vers vous pour un souci de confort ou plutôt pour un souci de gain de temps.
Dans mon boulot, cela peut étonner, mais chaque seconde gagnée sur une action et un temps précieux gagné car multiplié par des centaines de fois dans la journée.

Grâce à Job75 qui m'a "concocté" un code précieux que j'ai pu adapter, j'ai automatiser une recherche très importante pour mon travail.

Au code de Job75, j'ai ajouté une boucle pour m'éviter de cliquer sur un bouton pour chaque recherche demandée (il peut m'arriver d'avoir 500 recherches à faire).

Tout ça fonctionne super bien et encore un vrai merci à Job75 🙂

Toutefois, pas très bon en vba que je suis 😕, je pense qu'il peut y avoir une amélioration sensible, notamment pour écourter le temps de traitement qui me semble long.

Le fichier test joint
Explications en feuille "comment je travaille"
Pour que vous puissiez en juger, j'ai laissé 4000 lignes dans la base feuille "Agents"
Sachant qu'il y a environ 36000 communes en France (il s'agit de communes), mon fichier de travail est déjà bien plus lourd.

Le poids du fichier excel est de 1.40 Mo
En zippant j'obtiens 680 Ko
C'est pkoi, pour ne trop encombrer notre forum, j'ai préparé un zip.
OUPsss, le site n'accepte pas le zip,
Je mets donc le fichier excel.

Un grand merci à toutes et à tous pour déjà m'avoir lu.
Amicalement,
Arthour973,

 

[job75]

Bonjour Lionel,

Ce que tu avais fait n'allait vraiment pas, j'y ai mis de l'ordre avec cette macro :

Sub Rechercher()
Dim F As Worksheet, d As Object, tablo, i&, resu(), n&, j%
Set F = Feuil4 'CodeName de la feuille de destination
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
'---liste des villes à rechercher---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
tablo = F.Range("B1", F.Range("B" & F.Rows.Count).End(xlUp)(2)) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
If tablo(i, 1) <> "" Then d(tablo(i, 1)) = ""
Next
'---analyse du tableau source---
tablo = Feuil1.UsedRange.Columns("A:T") 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 19) 'tableau pour les résultats
For i = 1 To UBound(tablo)
    If d.exists(tablo(i, 3)) Then
        n = n + 1
        For j = 1 To 19: resu(n, j) = tablo(i, j + 1): Next
    End If
Next
'---restitution---
If n Then
    F.[D2].Resize(n, 19) = resu
    F.[D2].Resize(n, 19).Borders.Weight = xlHairline 'bordures
End If
F.Range("D" & n + 2 & ":V" & F.Rows.Count).Delete xlUp 'RAZ en dessous
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub

Fichier joint - le zip passe très bien...

A+

 

[cp4]

Bonsoir Arthour973🙂, Job75🙂, Le Forum😉,

J'avais ça sous la main je te le file😀. Pour remplacer les lettres avec accents, nul besoin de passer en revue jusqu'à la ligne 1000.

Sub ModifNomsCommunes()
   Dim c As Range, Sh As Worksheet
   Set Sh = Sheets("vérifie secteur")
   For Each c In Sh.Range("w3:w" & Sh.Range("w" & Rows.Count).End(xlUp).Row)
      c = Sans_accents(c)
   Next
End Sub

Function Sans_accents(chaine As Range)
   Dim T As String, A As String, B As String
   Dim i As Integer, U As String
   If chaine.Value = "" Then Exit Function
   T = chaine.Value
   'remplacement des caractères accentués
   A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
   B = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
   For i = 1 To Len(T)
      U = InStr(1, A, Mid(T, i, 1), 0)
      If U Then Mid(T, i, 1) = Mid(B, U, 1)
   Next i
   Sans_accents = T
End Function

Bonne soirée et bon week-end.😉

 

[job75]

Bonjour Lionel, cp4, le forum,

Dans mon fichier (1) la MFC en colonne B se calcule avec une formule NB.SI, ça peut prendre du temps.

Dans ce fichier (2) j'ai donc modifié la macro pour simplifier la MFC en plaçant des repères en colonne C :

Sub Rechercher()
Dim F As Worksheet, d As Object, tablo, i&, source, resu(), lig&, n&, j%
Set F = Feuil4 'CodeName de la feuille de destination
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
F.[C:C].ClearContents 'effacement des repères en colonne C
'---liste des villes à rechercher---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
tablo = F.Range("B1:C" & F.Range("B" & F.Rows.Count).End(xlUp).Row)  'matrice, plus rapides
For i = 2 To UBound(tablo)
If tablo(i, 1) <> "" Then d(tablo(i, 1)) = i 'repère la ligne
Next
'---analyse du tableau source---
source = Feuil1.UsedRange.Columns("A:T") 'matrice, plus rapide
ReDim resu(1 To UBound(source), 1 To 19) 'tableau pour les résultats
For i = 1 To UBound(source)
    lig = d(source(i, 3))
    If lig Then
        n = n + 1
        For j = 1 To 19: resu(n, j) = source(i, j + 1): Next
        tablo(lig, 2) = " " 'repère invisible en colonne C
    End If
Next
'---restitution---
If n Then
    F.[C1].Resize(UBound(tablo)) = Application.Index(tablo, , 2)
    F.[D2].Resize(n, 19) = resu
    F.[D2].Resize(n, 19).Borders.Weight = xlHairline 'bordures
End If
F.Range("D" & n + 2 & ":V" & F.Rows.Count).Delete xlUp 'RAZ en dessous
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub

La formule de la MFC est alors très simple =ESTTEXTE(B1)*ESTVIDE(C1)

Bonne journée.

 

[Usine à gaz]

Bonjour Job,

Un grand merci LOL
Évidemment j'avais tout faux.
ça marche super et rapide quasi instantané. Vraiment bien 🙂
Je vais prendre la version 2.
Je ne sais que dire 😉
Bon WE à toi,
Amicalement,
Lionel,

 

[Usine à gaz]

Bonjour CP4,

Je te remercie pour ton code 🙂
Bon WE à toi aussi,
Amicalement,
arhtour973