Problème clé à l'aide d'un tableau vba

Version imprimable

Voir 40 message(s) de cette discussion en une page

14/08/2015, 10h19
aziz1015

Bonjour,

Je dois malheureusement reconnaitre que vous avez raison ! Je vais essayer de faire plus simple en Access la semaine prochaine !

Merci pour votre aide

Cordialement

Tu pourrais au moins tester la proposition de mayekeul puis en restituer un retour ! …

http://smileys.sur-la-toile.com/repo...s/plus-un2.gif avec l'ami de la Belle Province !

J'ai oublié la monstruosité du classeur, question rapidité l'objet Dictionary peut effectivement rendre service …

Mais, n'ayant toujours pas connaissance de la version d'Excel malgré la possibilité de l'indiquer en préfixe du titre,
je ne peux donc assurer ma seconde démonstration n'explose pas les ressources système avec le classeur de travail !

Comme promis j'ai aussi préparé un dictionnaire sans Find fonctionnant à la vitesse de l'éclair avec le classeur de test joint :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub Demo2() VA = Feuil1.Cells(1).CurrentRegion.Columns("A:B").Value ReDim TC$(2 To UBound(VA), 0) With CreateObject("Scripting.Dictionary") For R& = 2 To UBound(VA) If .Exists(VA(R, 1)) Then TC(.Item(VA(R, 1)), 0) = TC(.Item(VA(R, 1)), 0) & " | " & VA(R, 2) _ Else .Add VA(R, 1), R: TC(R, 0) = VA(R, 2) Next .RemoveAll End With With Application .Calculation = xlCalculationManual: .EnableEvents = False: .ScreenUpdating = False Feuil1.[C2].Resize(UBound(TC) - 1).Value = TC .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub
_______________:yaisse1: _________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé …

_____________________________________________________________________________________________________
La perfection est atteinte non pas quand il n’y a plus rien à ajouter, mais quand il n’y a plus rien à retirer ! (Antoine de St Exupéry

Bonjour à tous, :D

A la bourre moi :weird:

Code:

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
Option Explicit
Option Base 1
 
Sub test()
Dim a, b(), i As Long, e, txt As String
    With Sheets("Feuil1")
        .Columns(3).Clear
        a = .Range("a1").CurrentRegion.Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    .Item(a(i, 1)) = a(i, 2)
                Else
                    txt = .Item(a(i, 1))
                    txt = txt & "**" & a(i, 2)
                    .Item(a(i, 1)) = txt
                End If
            Next
            ReDim b(1 To UBound(a, 1), 1)
            For i = 2 To UBound(a, 1)
                For Each e In .keys
                    If a(i, 1) = e Then
                        b(i, 1) = .Item(e)
                        .Remove (e)
                        Exit For
                    End If
                Next
                If .Count = 0 Then Exit For
            Next
        End With
        .Range("c1").Resize(UBound(b, 1), 1).Value = b
    End With
End Sub

klin89

14/08/2015, 17h08
aziz1015

Citation:

Envoyé par mayekeul

ça devrais être assez rapide je pense même pour plus de 100 000 enregistrement.
et définitivement, arretez de vouloir faire passer excel pour un gestionnaire de base de données... c'est pas fait pour!

Bonjour,

Vous avez en effet raison, votre proposition de macro met moins de 30 minutes pour créer des clés sur tout le classeur et qui plus est les crée très bien !

Merci infiniment

Citation:

Envoyé par Marc-L

J'ai oublié la monstruosité du classeur, question rapidité l'objet Dictionary peut effectivement rendre service …

Merci pour votre aide

Bonjour, j'ai un problème avec votre proposition, elle n'affiche rien ! J'ai bien entendu identifier la feuille du classeur dans laquelle faire les filtres, j'ai aussi mis les données dans les deux premières colonnes mais rien d'autre !

Dois je faire quelque chose d'autre ?

Cordialement
14/08/2015, 19h15
Marc-L

Déjà commencer par la tester sur le classeur de test joint dans le post #14 …
15/08/2015, 01h37
aziz1015

Re,

C'est bon ça fonctionne bien ! Et aussi, je crois que le PC y joue un grand rôle ! A la maison, j'ai un Windows7 64GB Core i7 et Excel 2013, votre code et celui de mayekeul s'exécutent en moins de 30 secondes chacun alors qu'au bureau il faut compter des minutes voir des heures ! Pare contre lorsque, je veux après supprimer les lignes vides dues à la création de clé ça reste très lent quelque soit la méthode utilisée mais bon ça le fait au bout de 30 minutes voir une heure sur mon PC ! Au bureau, encore des heures, je suis sur Excel 2010 Windows7 32GB au bureau !

Merci pour votre aide
15/08/2015, 01h45
Marc-L

Pour une suppression rapide :

• trier la plage sur une colonne contenant des cellules vides (optionnel mais améliore la rapidité de la suppression)
• filtrer la colonne sur les cellules vides
• supprimer la plage filtrée.

Sinon autre voie en créant une nouvelle feuille puis en y exportant les données via un filtre avancé
ou directement lors de la concaténation, rien à supprimer !

J'ai fait exactement ces deux méthodes et elles me prennent plus d'une heure aussi bien l'une que l'autre !

Code:

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
35
36
37
Sub Creer_fichier_sans_vide()
 
Dim WsSource As Worksheet, filtre As Workbook, WsCible As Worksheet
Set WsSource = ThisWorkbook.Sheets("Feuil6")
On Error Resume Next: WsSource.ShowAllData: On Error GoTo 0
Application.ScreenUpdating = False
Set WsCible = ThisWorkbook.Sheets.Add(After:=WsSource)
 
 
        WsCible.Name = "PVCSomme(GTPRIX)"
 
        Set filtre = Workbooks.Add
        filtre.Sheets(1).Range("A1") = "PVC(Somme(GTPRIX))"
 
        filtre.Sheets(1).Range("A2") = "<>"
 
        FiltreActif WsSource.UsedRange, filtre.Sheets(1).UsedRange, WsCible.Range("A1")
        filtre.Close False
        Set filtre = Nothing
        Application.ScreenUpdating = True
 
End Sub
 
Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
 RangeSource.AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=CriterRange _
        , CopyToRange:=CopyRange, Unique:=Unique
        DoEvents
        If Err = 0 Then FiltreActif = True
        MsgBox Err.Description
        On Error GoTo 0
        End If
End Function
 
Plus d'une heure me prend ce code que j'ai l'habitude d'utiliser pour exporter des données mais bon pas sur 70 000 lignes :?

En concaténant les données de la feuille 1 pour créer un nouveau tableau dans la feuille 2 :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub Demo3() VA = Feuil1.Cells(1).CurrentRegion.Columns("A:B").Value ReDim TC$(1 To UBound(VA) - 1, 1 To 2) With CreateObject("Scripting.Dictionary") For R& = 2 To UBound(VA) If .Exists(VA(R, 1)) Then TC(.Item(VA(R, 1)), 2) = TC(.Item(VA(R, 1)), 2) & " | " & VA(R, 2) _ Else .Add VA(R, 1), .Count + 1: TC(.Count, 1) = VA(R, 1): TC(.Count, 2) = VA(R, 2) Next R = .Count: .RemoveAll End With With Application .Calculation = xlCalculationManual: .EnableEvents = False: .ScreenUpdating = False Feuil2.Cells(1).CurrentRegion.Offset(1).Clear Feuil2.[A2].Resize(R, 2).Value = TC Feuil2.Cells(1).CurrentRegion.Columns.AutoFit .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub
_____________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé …

_____________________________________________________________________________________________________
Découvrir, c’est voir la même chose que les autres et penser autrement. (Albert von Szent-Györgyi)

Citation:

Envoyé par aziz1015

J'ai fait exactement ces deux méthodes et elles me prennent plus d'une heure aussi bien l'une que l'autre !

Ton code n'a aucun rapport avec la méthodologie exposée en trois points dans mon post #28 ‼
Si elle est bien suivie - et c'est du niveau d'un débutant ! - elle est la plus "rapide" …

En attendant un retour suite à mon post précédent, je peux affirmer que s'il s'agit bien de conserver uniquement
les valeurs regroupées en colonne B - purée, c'est simple à expliquer dès le premier post et sans compter
qu'il n'est vraiment pas compliqué lorsqu'un classeur est demandé de le joindre avec une feuille source et une feuille résultat ‼ -
comme la colonne clef est classée on en revient alors au post #10 (on en est quand même au 31 ‼) :

Citation:

Envoyé par Marc-L

donc le dictionnaire ne sert pas à grand chose tel qu'il est utilisé dans ce cas précis !
Avec un peu de jugeote pourtant … La réflexion mène au code, pas le contraire !

Non seulement un dictionnaire n'est pas nécessaire même pour une question de volume et de rapidité
et pour supprimer les lignes sans valeurs regroupées un filtre ne l'est pas non plus ‼
Avec un peu de jugeote, en grillant une paire de neurones, une simple variable tableau suffit à elle seule pour le tout …

_____________________________________________________________________________________________________
Il n'y a pas que les aigles qui atteignent les sommets, les escargots aussi mais ils en bavent !

15/08/2015, 15h34
aziz1015

Citation:

Envoyé par Marc-L

Ton code n'a aucun rapport avec la méthodologie exposée en trois points dans mon post #28 ‼
Si elle est bien suivie - et c'est du niveau d'un débutant ! - elle est la plus "rapide" …

J'ai bien expliqué en fait que les deux méthodes que j'ai utilisé m'ont pris plus d'une heure "DEUX" ! Je vous ai juste montré le code de la seconde !

Citation:

Envoyé par Marc-L

Pour une suppression rapide :

• trier la plage sur une colonne contenant des cellules vides (optionnel mais améliore la rapidité de la suppression)
• filtrer la colonne sur les cellules vides
• supprimer la plage filtrée.

Cette méthode que j'avais déjà essayé depuis hier me prend aussi plus d'une heure !

Citation:

Envoyé par Marc-L

Sinon au lieu de supprimer, créer une autre feuille puis y exporter les données via un filtre avancé …

Cette méthode est clairement celle que j'ai utilisé dans mon code que je viens de vous montrer !

Citation:

Envoyé par Marc-L

En attendant un retour suite à mon post précédent, je peux affirmer que s'il s'agit bien de conserver uniquement
les valeurs regroupées en colonne B - purée, c'est simple à expliquer dès le premier post et sans compter

La problématique n'était pas la peine depuis le début ! Si vous suivez bien, la création de clés laisse des champs vides et ce sont les lignes de ces champs vides que je voudrais supprimer ! Peut être aurais je du créer un autre post ! Toutefois malgré le temps d'exécution, j'ai atteint mon résultat !

Merci pour votre aide

Citation:
Envoyé par Marc-L
En concaténant les données de la feuille 1 pour créer un nouveau tableau dans la feuille 2 :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub Demo3() VA = Feuil1.Cells(1).CurrentRegion.Columns("A:B").Value ReDim TC$(1 To UBound(VA) - 1, 1 To 2) With CreateObject("Scripting.Dictionary") For R& = 2 To UBound(VA) If .Exists(VA(R, 1)) Then TC(.Item(VA(R, 1)), 2) = TC(.Item(VA(R, 1)), 2) & " | " & VA(R, 2) _ Else .Add VA(R, 1), .Count + 1: TC(.Count, 1) = VA(R, 1): TC(.Count, 2) = VA(R, 2) Next R = .Count: .RemoveAll End With With Application .Calculation = xlCalculationManual: .EnableEvents = False: .ScreenUpdating = False Feuil2.Cells(1).CurrentRegion.Offset(1).Clear Feuil2.[A2].Resize(R, 2).Value = TC Feuil2.Cells(1).CurrentRegion.Columns.AutoFit .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub
_____________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé …

_____________________________________________________________________________________________________
Découvrir, c’est voir la même chose que les autres et penser autrement. (Albert von Szent-Györgyi)
Heu merci pour ce code qui exécute parfaitement toutes les étapes tout en supprimant les lignes vides et tout ce ceci en moins de 10 secondes !

Merci

Citation:

Envoyé par Marc-L

Non seulement un dictionnaire n'est pas nécessaire même pour une question de volume et de rapidité
et pour supprimer les lignes sans valeurs regroupées un filtre ne l'est pas non plus ‼
Avec un peu de jugeote, en grillant une paire de neurones, une simple variable tableau suffit à elle seule pour le tout …

Voici donc une démonstration illustrant mon propos, sans dictionnaire (il "ralentit" la procédure & gâche des ressources)
ni filtre ni suppression et pourtant les lignes sans regroupement n'apparaissent plus :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub Demo4() With Application .Calculation = xlCalculationManual: .EnableEvents = False: .ScreenUpdating = False With Feuil1.Cells(1).CurrentRegion.Offset(1).Columns("A:B") VA = .Value ReDim TC$(1 To UBound(VA), 1): TC(1, 1) = VA(1, 2): TC(1, 0) = VA(1, 1): L& = 1 For R& = 2 To UBound(VA) If VA(R, 1) = TC(L, 0) Then TC(L, 1) = TC(L, 1) & " | " & VA(R, 2) _ Else L = L + 1: TC(L, 1) = VA(R, 2): TC(L, 0) = VA(R, 1) Next .Value = TC .AutoFit End With .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub
D'où l'intérêt de se conformer aux règles du forum avec une présentation digne de ce nom, claire & exhaustive …
Sinon les chances d'obtenir une réponse satisfaisante se réduisent tout en augmentant le risque de l'usine à gaz !

_____________________________________________________________________________________________________

:fleche: Merci de cliquer sur :plusser: pour chaque message ayant aidé

_____________________________________________________________________________________________________
De la précision nait la solution …

Voir 40 message(s) de cette discussion en une page