Discussion :

[Poussemousse]

Bonjour,
ayant tourné en rond depuis un moment, je me permets de repasser sur le forum pour avoir vos avis de spécialistes.

Je possède un feuille Excel comprenant plus de 7000 lignes et une quinzaine de colonnes.

La feuille porte sur un grand nombre de licenciés Hommes ou Femmes faisant partie de N clubs (N > 80).
Pour chaque club, j'ai besoin de créer dans cette feuille 3 noms (ActiveWorkbook.Names.Add ....) qui me permettront ensuite de faire des listes de sélection ou des choix de recherche de tableaux automatiques.

Ma première idée a été de faire un filtre général et une seule fois sur le nom de club, puis sur le sexe et enfin sur le nom du licencié.
Ensuite, en descendant tout le tableau ligne à ligne je regarde si le nom du club change ou si le sexe change.
J'enregistre alors les N° de lignes correspondant, et à chaque détection d'un nouveau club je crée mes 3 noms Si je fais ça il me faut environ 30 à 40s, pas de gain de temps à scanner les cellules Excel ou à passer par un Variant.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
For i = 3 To NbLig + 1
 
        If Montab(i - 1, 2) = "F" And Montab(i, 2) = "H" Then
            Rang_F_Stop = i - 1
            Rang_H_Start = i
        End If
 
        Club2 = Montab(i, 9)
        If Club2 <> Club1 And Club2 <> "" Then
            NomsClub(j) = Club1
            j = j + 1
 
            Rang_H_Stop = i - 1
 
            Joueurs_F = "J_" & Club1 & "_F"
            Joueurs_H = "J_" & Club1 & "_H"
            Licencies = "L_" & Club1
 
            'Affectation des noms des listes et zones Joueurs et Licence/Classements
            'Note il faut passer par ReferToR1C1 sinon décalage...
            If Rang_F_Start <= Rang_F_Stop Then
                ActiveWorkbook.Names.Add name:=Joueurs_F, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_F_Start & "C1:R" & Rang_F_Stop & "C1"
            End If
            If Rang_H_Start <= Rang_H_Stop Then
                ActiveWorkbook.Names.Add name:=Joueurs_H, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_H_Start & "C1:R" & Rang_H_Stop & "C1"
            End If
            ActiveWorkbook.Names.Add name:=Licencies, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_F_Start & "C1:R" & Rang_H_Stop & "C13"
 
            If Montab(i, 2) = "F" Then
                Rang_F_Start = i
            End If
            Club1 = Club2
        End If
    Next

Ma 2° idée a été de me créer la liste des clubs (pour gagner du temps : c'est très rapide avec les filtres avancés en éliminant les doublons), de faire ensuite pour les N club un filtrage sur leur nom et de recherche les première/dernière femmes et premiers/derniers hommes.
Là c'est pire, car à chaque filtre Excel fait son raffraichissement d'écran, et comme j'en ai à peu plus de 80 là aussi c'est long.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 
For i = 1 To NbClub
        'Rows("1:1").Select
        ActiveSheet.Range("A1:M" & NbLig).AutoFilter Field:=12, Criteria1:=Sheets("LISTE_CLUBS").Range("A" & 50 + i).Value
        Set Trouve = ActiveSheet.Columns(2).Cells.Find(what:="F", LookAt:=xlWhole)
        Rang_F_Start = Trouve.Row
 
        Set Trouve = ActiveSheet.Columns(2).Cells.Find(what:="H", LookAt:=xlWhole)
        Rang_H_Start = Trouve.Row
        Rang_F_Stop = Rang_H_Start - 1
        Rang_H_Stop = Rang_H_Start - 1 + [SUBTOTAL(3,A:A)] - (Rang_F_Stop - Rang_F_Start + 1)
 
        Joueurs_F = "J_" & Club1 & "_F"
        Joueurs_H = "J_" & Club1 & "_H"
        Licencies = "L_" & Club1
 
        'Affectation des noms des listes et zones Joueurs et Licence/Classements
        'Note il faut passer par ReferToR1C1 sinon décalage...
        'If Rang_F_Start <= Rang_F_Stop Then
            ActiveWorkbook.Names.Add name:=Joueurs_F, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_F_Start & "C1:R" & Rang_F_Stop & "C1"
        'End If
        'If Rang_H_Start <= Rang_H_Stop Then
            ActiveWorkbook.Names.Add name:=Joueurs_H, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_H_Start & "C1:R" & Rang_H_Stop & "C1"
         'End If
            ActiveWorkbook.Names.Add name:=Licencies, RefersToR1C1:="=" & Nomfeuille & "!R" & Rang_F_Start & "C1:R" & Rang_H_Stop & "C13"
 
    Next

Je me posais donc la question de savoir si on pouvait faire des filtres sur un Variant qui contiendrait le contenu de la feuille ?

Mes capacités à utiliser les tableaux de Variant pour faire autre chose que du calcul simple ou de la manipulation de chaines de caractères s'arrêtent là, merci de votre support et de vos idées géniales

[eriiic]

Bonjour,

une feuille en situation avec qq ligne de données bidons et les plages à nommer ?
eric

[Poussemousse]

Bonjour Eriiic,

ci-après le fichier exemple.

Attention par rapport à mon code précédent une évolution : Montab(i,12) à prendre en compte à la place de Montab(i,9).

En fait ça prend 60s avec la solution passant par Montab.

[eriiic]

J'ai hésité entre travail en mémoire et utilisation de fonctions feuille et opté finalement pour le 2nd choix.
Moins d'1 s tri compris, c'est raisonnable :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub noms()
    Dim lig As Long, derlig As Long
    Dim equ As String, nbL As Long, nbF As Long, nbH As Long
    Dim nomEqu As String
    Dim t As Single
    t = Timer
    [A:L].Sort Key1:=Range("L2"), Order1:=xlAscending, _
        Key2:=Range("B2"), Order2:=xlAscending, _
        Header:=xlYes
    lig = 2
    derlig = Cells(Rows.Count, 1).End(xlUp).Row
    Do
        equ = Cells(lig, 12)
        nbL = Application.CountIf([L:L], equ)
        nomEqu = "L_" & equ
        Range(Cells(lig, 1), Cells(lig + nbL - 1, 1)).Name = nomEqu
        nbF = Application.CountIf(Range(nomEqu).Offset(, 1), "F")
        nbH = Application.CountIf(Range(nomEqu).Offset(, 1), "H")
        If nbL <> nbF + nbH Then
            MsgBox "Anomalie sur équipe " & equ & vbLf & "Noms non posés."
        Else
            If nbF > 0 Then Range(nomEqu).Resize(nbF).Name = "J_" & equ & "_F"
            If nbH > 0 Then Range(nomEqu).Offset(nbF).Resize(nbH).Name = "J_" & equ & "_H"
        End If
        lig = lig + nbL
    Loop Until lig > derlig
    MsgBox Timer - t
End Sub

regarde si ça va.
Une fois les noms posés plus le droit aux tris !
eric

[Poussemousse]

Eriiic merci de ton retour.
Sur un premier test je gagne du temps mais j'arrive tout de même à 30s avec mes "vraies" données.
Par rapport à ton code, j'ai juste repris les noms J_clubxxx_H et F qui ne sont pas une sous partie de L_clubxx, mais 2 tableaux A:F avec les mêmes lignes.
En déplacement pour plusieurs jours j'essaierai au calme et te redis, en tous les cas ta réponse m'a encore appris plein de choses, merci.

[Invité]

Bonjour,
Tu devrais regarder du côté Adodb!
http://www.developpez.net/forums/d15...e/#post8651942

si le sexe change

là je ne sais pas répondre!

[eriiic]

Bonjour à tous,

J'aurais bien fait un test en mémoire mais vu que tes 7500 lignes mettent 0.8s chez moi avec ma 1ère proposition je doute que ça fasse faire un bond significatif.
rdurupt a un doute sur ta liaison de données et comme je n'ai pas vraiment de compétences là dessus je te laisse voir avec lui. Il a souvent de bonnes idées.
eric

[Invité]

un début!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub test()
Const Fichier = "C:\Users\rdurupt\Desktop\Poussemousse_exemple_001.xlsx"
Dim Sql As String, RsClub As Object, Cn As Object
Set Cn = CreateObject("Adodb.connection")
With Cn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0 Xml;IMEX=1;"""
        .Open
        Set RsClub = CreateObject("Adodb.recordset")
        Sql = "Select Distinct [N° Club] from [Export_hebdo$] where [N° Club] Is Not Null order By [N° Club]"
        RsClub.Open Sql, Cn
        While RsClub.EOF = False
            GestionClub CStr(RsClub("N° Club").Value), Cn
            RsClub.movenext
        Wend
        RsClub.Close: Set RsClub = Nothing
        .Close
    End With
    Set Cn = Nothing
End Sub
Sub GestionClub(Club As String, Cn As Object)
Dim Sql As String, RsSexeF As Object, RsSexeH As Object
Set RsSexeF = CreateObject("Adodb.recordset")
Set RsSexeH = CreateObject("Adodb.recordset")
RsSexeF.Open "Select * from [Export_hebdo$] where [N° Club] ='" & Replace(Club, "'", "''") & "' and [Genre]='F'", Cn
RsSexeH.Open "Select * from [Export_hebdo$] where [N° Club] ='" & Replace(Club, "'", "''") & "' and [Genre]='H'", Cn
RsSexeF.Close: RsSexeH.Close
Set RsSexeF = Nothing: Set RsSexeH = Nothing
End Sub

Édite:
Désolé ma solution n'est pas viable pour ce genre de traitement!
en revanche avec le proposition eriiic j’arrive à 0.16s

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Application.EnableEvents = False
Application.ScreenUpdating = False

[Poussemousse]

Eric & Rudupt,

merci de vos retours.
L'erreur provient vraisemblablement de quelque chose qui se trouve ailleurs de cette macro mais chez moi, car quand j'exécute le code d'Eric sur mon propre fichier exemple qui a été nettoyé, je mets aussi environ 1s.

Si j'intègre la macro dans mon fichier d'origine, l'onglet en question qui contient toutes les info est un de mes "nombreux" onglets, le fait de créer un Nom dans la feuille me coûte 12s pour l'ensemble des 84 clubs.
Comme j'ai 3 fois des noms à créer je retrouve bien mes 36 secondes.
Je n'ai donc pas de souci de temps d'accès à la base puisqu'elle fait partie du fichier Excel.

Il me faut passer à la chasse au ralentisseur en dégrossisant petit à petit mes onglets et mes autres macros.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Application.EnableEvents = False
Application.ScreenUpdating = False

J'ai testé et cela ne change rien.

A tout hasard, savez-vous comment retrouver les macros du type "on change" quelque part dans un projet global, sans devoir aller dans les macro de chaque onglet et feuille (normalement Application.EnableEvents = False devrait l'en empêcher).
Je n'ai pas le souvenir d'en avoir utilisé, mais il doit y avoir quelque chose du genre qui tourne en arrière plan.

Il me reste à trouver quoi et où, je vous tiens informé et signalerai le post RESOLU dès que j'aurai trouvé.

[eriiic]

Si avec enabledEvents=false ça ne change rien, peu de chance que ce soit dû à un événement.
Tu n'as pas de matricielles gourmandes ou de MFC ? Bien que je ne vois pas pourquoi poser un nom entrainerait un recalcul (?)

Pour élargir les désactivations :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    ' niveau Feuille, pour chaque feuille concernée :
    With Sheets("Feuil1")
        ' saut de page
        .DisplayPageBreaks = False
        ' feuille avec données sources contenues dans des fichiers csv ou txt externes.
        .EnableCalculation = False
        ' >=2007: calcul formats conditionnels
        .EnableFormatConditionsCalculation = False
    End With

A restaurer en fin de proc

[Poussemousse]

Éric,
J'ai trouvé, je n'avais pas de Mise en Forme Conditionnelle (une seule cellule) par contre ce sont toutes mes rechercheV qui pointaient sur me tables nommées ralentissaient bien la macro.
Avec ton code je descends à 0.26 seconde !

Par contre quelle est la formule à mettre dans la macro pour réactiver automatiquement les calculs et résultats des recherchev sans avoir à revalider les cellules ?
J'ai mis la même chose en remplaçant False par True mais il doit encore manquer un petit quelque chose.

[eriiic]

le mieux c'est de sauvegarder l'état avant de le modifier :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

calcState = Application.Calculation

et de restaurer le paramétrage de l'utilisateur à la fin :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.Calculation = calcState

Sinon la valeur par défaut est xlCalculationAutomatic (-4105, tu étais loin).
Quand tu ne sais pas la valeur commence avec Application.Calculation =xl et utilise l'autocomplétion avec Ctrl+Espace pour voir la liste des constantes valides.
+ sheets("Feuil1").Calculate si besoin

[Poussemousse]

Eric, l'argument étant actif au niveau classeur je le passe carrément à Manual en début de procédure et je le force en automatique à la fin

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Application.Calculation = xlCalculationManual
....
Application.Calculation = xlCalculationAutomatic

de cette façon c'est royal et j'arrive à faire tout ce que je veux en moins d'une seconde (ajout de la suppression de tous les anciens noms définis, et création d'une table avec les nouveaux noms.

Post maintenant résolu, encore merci pour votre support et votre aide très constructive.