Discussion :

[Invité]

Bonsoir,

Afin de faire une espèce de tableau de bord, je dois extraire des données d'une BD et transférer celles-ci sur la feuille "TxBord",
en effectuant un premier filtre dont les critères sont les valeurs VAL18=Sheets("TxBord").Range("H4") et VAL3=Sheets("TxBord").Range("D4")

J'ai fait une partie du code en utilisant des dictionnaires (que je ne maitrise pas très bien), je suis parvenu à extraire les valeurs de 2 colonnes
VAL4 et VAL5 par contre je n'arrive pas à extraire la 3ème (VAL6). Il y a un truc qui m'échappe avec ces satanés dictionnaires
(ces questions de keys et items qui m'embrouillent).

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Option Explicit
 
Sub Tx_Bord()
Dim i As Long, j As Long, k As Long, NBd As Long, NCr As Long, DL As Long, LaDate As Long
'Dim Ouvrage As String, Tronçon As String
Dim TypeCamp As String
Dim ShBd As Worksheet, ShTxB As Worksheet
Dim Plage As Range, c As Range, v As Range
Dim Prise(), Ouvrage(), Tronçon()
Dim tOuv As Object, tTrc As Object
Dim temp As Variant, temp1 As Variant, temp2 As Variant
 
 
Application.ScreenUpdating = False
 
Set ShBd = Worksheets("BD")
NBd = ShBd.Cells(ShBd.Rows.Count, 1).End(xlUp).Row
 
Set ShTxB = Worksheets("TxBord")
With ShTxB
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    If DL > 7 Then .Range("A8:K" & DL).Clear
 
    LaDate = .Range("C4")                    'DATE
    TypeCamp = .Range("H4")                   'REFERENCE
 
    With ShBd
            .AutoFilterMode = False
            .Range("A1:AA" & NBd).AutoFilter Field:=18, Criteria1:=TypeCamp
            .Range("A1:AA" & NBd).AutoFilter Field:=3, Criteria1:=CDate(LaDate)
 
            Set tOuv = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
            For Each c In .Range("D2:D" & NBd).SpecialCells(xlCellTypeVisible)
            tOuv(c.Value) = ""
            Next c 'prochaine cellule de la boucle
            temp = tOuv.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
            For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
 
               .Range("A1:AA" & NBd).AutoFilter Field:=4, Criteria1:=temp(i)
 
                Set tTrc = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
 Set Plage = .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                For Each c In Plage 'c In .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                'If c <> "" Then tTrc.Add c.Value, c.Offset(, 1).Value
                tTrc(c.Value) = ""
                Next c 'prochaine cellule de la boucle
                temp1 = tTrc.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
                For j = 0 To UBound(temp1) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
 
                    .Range("A1:AA" & NBd).AutoFilter Field:=5, Criteria1:=temp1(j)
 
                        With ShTxB
                        For k = 0 To UBound(temp1)
                          .Cells(k + 8, 2) = temp(i)    'récupérer valeur col4
                          .Cells(k + 8, 3) = temp1(k)   'récupérer valeur col5
                          .Cells(k + 8, 4) = ""         'récupérer valeur col6
                          .Cells(k + 8, 5) = ""         'moyenne cellules visibles col9
                          .Cells(k + 8, 6) = ""         'moyenne cellules visibles col10
                          .Cells(k + 8, 7) = ""         'sum1(s or cps) -sum2((i or adf) and val11=vide)
                          .Cells(k + 8, 8) = ""         'dernière val7 - première val7 (ligne visible hors entete)
                          .Cells(k + 8, 9) = ""         'voir formule
                          .Cells(k + 8, 10) = ""        '
 
                        Next k
 
                        End With
                 Next j
            Next i
 
            .AutoFilterMode = False
        End With
 End With
Set ShBd = Nothing
Set ShTxB = Nothing
End Sub

Pour les autres colonnes, il y a quelques calculs à faire, je commence par les plus simples:
Pour VAL9 et VAL10 c'est la moyenne des colonnes correspondantes filtrées
Pour VAL7, c'est la différence entre la dernière cellule et la première cellule visible (entete non pris en compte)
Pour %VAL, c'est le ration entre le nombre de cellules (VAL10) dont la valeur est <=-600 et le nombre de cellules non vides de la même colonne (VAL10)
Pour VAL15, ça se complique un peu, il faut faire la somme des cellules dont en colonne VAL8 , il y a "S" ou "PS ou "CPS"
à laquelle il faudra soustraire le somme des cellules dont en colonne VAL8, il y aura "I" ou "ADF" ET dont la cellule correspondante en VAL11 est vide
Pour densité, elle se calcule ainsi: Résultat pour VAL19/(Pi*(Convert(VAL6,"in","m"))*VAL7)

En vous remerciant, j'ai commencé avec les dictionnaires mais toutes autres approches sera la bienvenue.

Cordialement,
http://cjoint.com/?0CqsfdVrr91

[Daniel.C]

Bonjour,

Qu'est-ce que tu cherches à faire en utilisant un dictionnaire ? Eliminer des doublons ?

[jijie]

VAL4 et VAL5 par contre je n'arrive pas à extraire la 3ème (VAL6). Il y a un truc qui m'échappe avec ces satanés dictionnaires
(ces questions de keys et items qui m'embrouillent).

OUI avec le dico il n'y a que la keys (clé) et un item nous venons juste de faire un post à ce sujet un peu plus bas! Mais tu pourras y voir qu'on peu l'améliorer!

Mais comme le dit Daniel il faut vraiment un DICO?
De plus dans l'utilisation de ton Dico il y a des choses qui interpelle ! Tu le charge ou?
Tu n’aurais pas un bout de fichier exemple?

[Invité]

Bonsoir,

Merci pour le retour. En effet, je cherche dans un premier à éliminer des doublons pour 2 colonnes. Je ne suis pas un fin connaisseur du vba, j'ai réussi à obtenir ce que je voulais pour cette étape. Il me reste le plus dur, faire les boucles pour récupérer les moyennes et tout le reste comme exposé au post#1.

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
 Sub Tx_Bord()
Dim i As Long, j As Long, k As Long, NBd As Long, NCr As Long, DL As Long, LaDate As Long
'Dim Ouvrage As String, Tronçon As String
Dim TypeCamp As String
Dim ShBd As Worksheet, ShTxB As Worksheet
Dim Plage As Range, c As Range, v As Range
Dim Prise(), Ouvrage(), Tronçon()
Dim tOuv As Object, tTrc As Object
Dim temp As Variant, temp1 As Variant, temp2 As Variant
 
Application.ScreenUpdating = False
 
Set ShBd = Worksheets("BD")
NBd = ShBd.Cells(ShBd.Rows.Count, 1).End(xlUp).Row
 
Set ShTxB = Worksheets("TxBord")
With ShTxB
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    If DL > 7 Then .Range("A8:K" & DL).Clear
 
    LaDate = .Range("C4")                    'DATE
    TypeCamp = .Range("H4")                   'REFERENCE
 
    With ShBd
            .AutoFilterMode = False
            .Range("A1:AA" & NBd).AutoFilter Field:=18, Criteria1:=TypeCamp
            .Range("A1:AA" & NBd).AutoFilter Field:=3, Criteria1:=CDate(LaDate)
 
            Set tOuv = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
            For Each c In .Range("D2:D" & NBd).SpecialCells(xlCellTypeVisible)
            tOuv(c.Value) = ""
            Next c 'prochaine cellule de la boucle
            temp = tOuv.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
            For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
  Stop
               .Range("A1:AA" & NBd).AutoFilter Field:=4, Criteria1:=temp(i)
 
                Set tTrc = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
                Set Plage = .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                For Each c In Plage 'c In .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                If Not tTrc.Exists(c.Value) Then tTrc.Add c.Value, c.Offset(0, 1).Value
                Next c 'prochaine cellule de la boucle
                temp1 = tTrc.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
                temp2 = tTrc.items
                For j = 0 To UBound(temp1) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
 Stop
                    .Range("A1:AA" & NBd).AutoFilter Field:=5, Criteria1:=temp1(j)
 
                        For k = 0 To UBound(temp1)
 
                         ShTxB.Cells(k + 8, 2) = temp(i)    'récupérer valeur col4
                          ShTxB.Cells(k + 8, 3) = temp1(k)   'récupérer valeur col5
                          ShTxB.Cells(k + 8, 4) = temp2(k) '""         'récupérer valeur col6
                          ShTxB.Cells(k + 8, 5) = ""         'moyenne cellules visibles col9
                          ShTxB.Cells(k + 8, 6) = ""         'moyenne cellules visibles col10
                          ShTxB.Cells(k + 8, 7) = ""         'sum1(s or cps) -sum2((i or adf) and val11=vide)
                          ShTxB.Cells(k + 8, 8) = ""         'dernière val7 - première val7 (ligne visible hors entete)
                          ShTxB.Cells(k + 8, 9) = ""         'voir formule
                          ShTxB.Cells(k + 8, 10) = ""        '
 
                        Next k
 
                Next j
            Next i
 
            .AutoFilterMode = False
        End With
 End With
Set ShBd = Nothing
Set ShTxB = Nothing
End Sub

J'ai mis des explications sur le fichier joint. Noter bien, je suis en apprentissage mon code ne suit sûrement pas les règles de codage à la lettre.

Merci beaucoup.

Cordialement,

[clementmarcotte]

Bonjour,

Bonsoir,

Merci pour le retour. En effet, je cherche dans un premier à éliminer des doublons pour 2 colonnes.

Cordialement,

Alors, pourquoi ne pas juste faire un filtre élaboré avec extraction sans doublon et, même, s'il le faut, sur une nouvelle feuille ? Ce sera probablement plus rapide qu'avec un dictionnaire.

[Invité]

Bonsoir jijie,

Excuses je n'avais pas vu ton post. Regarde au bas de mon post#1, il y a un lien pour le fichier.

Pour la partie du dico, je pense avoir trouver la solution (j'ai fait des corrections au premier code).

Je ne suis pas connaisseur du vba , je découvre et apprends tous les jours et J'avais bien dit dans mon premier post que tout autre approche sera la bienvenue. Ce n'est peut-être la meilleur idée.

Le but recherché, est de faire un récapitulatif, en partant de ma feuille "TxBord", on filtre la BD, premier filtre col18 critère = H4 et le deuxième filtre col3 critère = C4.

on récupère les valeurs sans doublons des colonnes D et E pour effectuer les boucles, afin de récupérer sur la feuille TxBord, les moyennes de 2 colonnes (I et J), le nombre de cellules non vide col J et nombre de cellules dont valeur <=-600 (faire ration et le mettre sur TxBord), tout est expliqué sur le fichier et au post#1.

merci beaucoup.

Bonsoir clementmarcotte,

J'ai bien mentionné que je dois faire une sorte de tableau de bord sur lequel, il va y avoir des données calculées à partir de la BD.

Pour les dictionnaires, c'est pour récupérer les valeurs sans doublons qui serviront à faire des boucles de filtre automatiques.

Les Filtres élaborés, à ma connaissances ne servent que pour effectuer des extractions un peu "sophistiquées", si je puis m'exprimer ainsi.

Ne m'en veuillez pas trop, je n'ai pas beaucoup de connaissances en vba, je sais qu'il y a énormément de choses dont je n'ai encore pas entendu parler.

Merci beaucoup.

Cordialement,

[Daniel.C]

Bonjour,

Personnellement, désolé, je passe la main. Une question, une ou des réponses, c'est l'esprit du forum. Là, tu nous bombardes avec des solutions qui ne fonctionnent pas et une batterie de questions. Je n'ai pas le temps, ni de déchiffrer ce que tu essaies d'exposer, ni de chercher à répondre.

[Invité]

Bonjour Daniel.C, le forum,

aucun souci mon cher Daniel.C.

Là, tu nous bombardes avec des solutions qui ne fonctionnent pas et une batterie de questions.

En effet, l'esprit du forum est une question à la fois. Mais on m'a déjà fait des reproches, du genre: "il fallait le dire plus tôt".

J'ai donc décidé de poser mon problème dans sa globalité, pour éviter certaine réflexion et pour ne pas avoir des bribes de code.

Vu mon faible niveau, mes codes ne sont pas "orthodoxes", j'en conviens. Mais pour ce fichier, désolé il est en bonne voie.

J'ai un peu avancé, plus que je suis parvenu à un résultat.

Je suis sûr et certain que mes erreurs viennent de mon manque de maitrise du langage VBA (comment désigner les "choses").

Mais bon, si tu jettes l'éponge ça ne fait rien. juste une question as-tu jeté un coup d’œil à mon fichier? (sans obligation de réponse)

Voilà, je mets le code et la nouvelle mouture du fichier (pour ceux qui voudront bien me donner un coup de main, le module se nomme "MonCode",

tous les autres sont des codes que j'ai trouvé, essayé de comprendre et d'adapter, dont l'un de Boisgontier qui m'a rendu un sacré service.)

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Option Explicit
 
Sub Tx_Bord()
Dim i As Long, j As Long, k As Long, NBd As Long, NCr As Long, DL As Long, LaDate As Long, x As Long, y As Long
Dim TypeCamp As String
Dim ShBd As Worksheet, ShTxB As Worksheet
Dim Plage As Range, c As Range, v As Range
Dim Prise(), Ouvrage(), Tronçon()
Dim tOuv As Object, tTrc As Object
Dim temp As Variant, temp1 As Variant, temp2 As Variant
 
Application.ScreenUpdating = False
 
Set ShBd = Worksheets("BD")
ShBd.AutoFilterMode = False
NBd = ShBd.Cells(ShBd.Rows.Count, 1).End(xlUp).Row
 
Set ShTxB = Worksheets("TxBord")
With ShTxB
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    If DL > 7 Then .Range("A8:K" & DL).Clear
 
    LaDate = .Range("C4")                    'DATE
    TypeCamp = .Range("H4")                   'REFERENCE
 
    With ShBd
            '.AutoFilterMode = False
            .Range("A1:AA" & NBd).AutoFilter Field:=18, Criteria1:=TypeCamp
            .Range("A1:AA" & NBd).AutoFilter Field:=3, Criteria1:=CDate(LaDate)
 
            Set tOuv = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
            For Each c In .Range("D2:D" & NBd).SpecialCells(xlCellTypeVisible)
            tOuv(c.Value) = ""
            Next c 'prochaine cellule de la boucle
            temp = tOuv.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
            For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
'Stop
               .Range("A1:AA" & NBd).AutoFilter Field:=4, Criteria1:=temp(i)
 
                Set tTrc = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
                Set Plage = .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                For Each c In Plage 'c In .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                If Not tTrc.Exists(c.Value) Then tTrc.Add c.Value, c.Offset(0, 1).Value
                Next c 'prochaine cellule de la boucle
                temp1 = tTrc.Keys 'récupère le dictionnaire sans doublon dans le tableau temp
                temp2 = tTrc.items
                For j = 0 To UBound(temp1) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
'Stop
                    .Range("A1:AA" & NBd).AutoFilter Field:=5, Criteria1:=temp1(j)
                       'première ligne filtrée d'après Boisgontier
                        If Range("b:b").SpecialCells(xlCellTypeVisible).Areas(1).Count > 1 Then
                         x = 2
                        Else
                         x = Range("b:b").SpecialCells(xlCellTypeVisible).Areas(2).Item(1).Row
                        End If
 
                        y = Plage.SpecialCells(xlCellTypeLastCell).Row      'dernière ligne filtrée
 
                          ShTxB.Cells(j + 8, 2) = temp(i)    'solution trouvée
                          ShTxB.Cells(j + 8, 3) = temp1(j)   'solution trouvée
                          ShTxB.Cells(j + 8, 4) = temp2(j)   'solution trouvée
                          ShTxB.Cells(j + 8, 5) = ""         'solution non trouvée, moyenne cellules visibles col9
                          ShTxB.Cells(j + 8, 6) = ""         'solution non trouvée, moyenne cellules visibles col10
                          ShTxB.Cells(j + 8, 6) = ""         'solution non trouvée
                          ShTxB.Cells(j + 8, 7) = ""         'solution non trouvée
                          ShTxB.Cells(j + 8, 8) = ""         'solution non trouvée
 
                          ShTxB.Cells(j + 8, 9) = (ShBd.Cells(y, 7).Value - ShBd.Cells(x, 7).Value)
                          ShTxB.Cells(j + 8, 9).NumberFormat = "0.00"
 
                          ShTxB.Cells(j + 8, 10) = ""        '
 
                Next j
            Next i
 
            .AutoFilterMode = False
        End With
 End With
Set ShBd = Nothing
Set ShTxB = Nothing
End Sub

http://cjoint.com/?0CrllGsElEO
En vous remerciant beaucoup. Cordialement,

[Daniel.C]

J'ai vu ton fichier. J'ai vu qu'il y avait d'autres répondeurs, aussi me suis-je permis de décrocher. Je vais néanmoins continuer à suivre les réponses.

[clementmarcotte]

Bonsoir clementmarcotte,

Pour les dictionnaires, c'est pour récupérer les valeurs sans doublons qui serviront à faire des boucles de filtre automatiques.

Les Filtres élaborés, à ma connaissances ne servent que pour effectuer des extractions un peu "sophistiquées", si je puis m'exprimer ainsi.


Cordialement,

J'abandonne.

Un filtre élaboré autorise les requêtes pour filtrer les données et aussi comme j'ai dit des extractions sans doublon.

Comme je disais, avec un filtre élaboré, tu peux extraire tes données filtrées et uniquement tes données filtrées sur une autre feuille, présumément vide.

Puisque tu peux avoir seulement tes données filtrées sur une nouvelle feuille, tu as juste à boucler sur les données de la nouvelle feuille, sans te badrer de ramasser des choses inutiles au travers.

Les filtres élaborés sont surtout intégrés dans le code d'Excel en langage machine et sont plus efficaces en performances que les dictionnaires, issus de la bibliothèque "Scripting" qui héberge également FileSystemObjet, désespéramment lent.

Ce qui me décourage le plus, c'est que tu prétends être ouvert à d'autres pistes que tes dictionnaires et que tu refuses visiblement d'apprendre.

Je vais quand même faire comme Daniel, du moins un certain temps.

J'ai fini par télécharger ton fichier et je te laisse cette question incontournable si tu veux arriver à un résultat :


Comment peux-tu savoir où sont tes erreurs et, par conséquent, avoir un/des résultat(s) approprié(s) et fiable(s) si tu te contentes de sauter à la ligne suivante avec :

Code :

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

On error resume next

en cas d'erreur. Parce que c'est cela que cette ligne fait.


Mémo aux responsables du site : cela prendrait une émoticône "découragé"

[Invité]

Bonsoir Clementmarcotte,

Dans mon code il n'y a pas de "On Error Resume next". Je ne vois pas comment résoudre ce problème avec les filtres élaborés.
D'ailleurs je ne les maitrise pas du tout. Si tu veux me donner un coup de main, j'ai fait une image pour te présenter le problème.
Et dis-moi, si d'après toi c'est réalisable avec les filtres élaborés.

Bonne soirée.

Cordialement,

[Invité]

Bonjour,

Après une bonne nuit blanche, je suis parvenu tant bien que mal à terminer ce que j'avais commencé.

N'étant qu'un amateur du dimanche, je suis sûr que mon code n'est pas "orthodoxe", mais il fonctionne.

j'ai découvert la fonction "soustotal" qui m'a sorti d'affaire. J'avoue que je sous-estimais cette fonction,

je pensais qu'elle ne servait qu'à faire des sous-totaux sur une feuille contenant un groupe Plan.

J'ai abordé ce fichier avec mes maigres connaissances du VBA. J'attends vos remarques et critiques pour améliorer ce code.

Ce n'est sûrement pas la bonne approche, car je sais que ce problème aurait pu être résolu en utilisant les tableaux (Array).

Hélas! je ne les maitrise pas du tout. Bon, voilà pour le partage j'édite mon code.

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 Option Explicit
 Dim a, b, d, e, f
Sub Tx_Bord()
Dim i As Long, J As Long, k As Long, NBd As Long, NCr As Long, DL As Long, LaDate As Long, x As Long, y As Long
Dim TypeCamp As String
Dim ShBd As Worksheet, ShTxB As Worksheet
Dim Plage As Range, C As Range, v As Range
Dim Prise(), Ouvrage(), Tronçon()
Dim tOuv As Object, tTrc As Object
Dim temp As Variant, temp1 As Variant, temp2 As Variant
Dim Ligne
 
Application.ScreenUpdating = False
 
Set ShBd = Worksheets("BD")
ShBd.AutoFilterMode = False
NBd = ShBd.Cells(ShBd.Rows.Count, 1).End(xlUp).Row
 
Set ShTxB = Worksheets("TxBord")
With ShTxB
    DL = .Cells(.Rows.Count, 2).End(xlUp).Row
    If DL > 7 Then .Range("A8:K" & DL).Clear
 
    LaDate = .Range("C4")                    'DATE
    TypeCamp = .Range("H4")                   'REFERENCE
 
    With ShBd
            '.AutoFilterMode = False
            .Range("A1:AA" & NBd).AutoFilter Field:=18, Criteria1:=TypeCamp
            .Range("A1:AA" & NBd).AutoFilter Field:=3, Criteria1:=CDate(LaDate)
 
            Set tOuv = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
            For Each C In .Range("D2:D" & NBd).SpecialCells(xlCellTypeVisible)
            tOuv(C.Value) = ""
            Next C 'prochaine cellule de la boucle
            temp = tOuv.keys 'récupère le dictionnaire sans doublon dans le tableau temp
            For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
'Stop
               .Range("A1:AA" & NBd).AutoFilter Field:=4, Criteria1:=temp(i)
 
                Set tTrc = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
                Set Plage = .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                For Each C In Plage 'c In .Range("E2:E" & NBd).SpecialCells(xlCellTypeVisible)
                If Not tTrc.Exists(C.Value) Then tTrc.Add C.Value, C.Offset(0, 1).Value
                Next C 'prochaine cellule de la boucle
                temp1 = tTrc.keys 'récupère le dictionnaire sans doublon dans le tableau temp
                temp2 = tTrc.items
                For J = 0 To UBound(temp1) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
 
                    .Range("A1:AA" & NBd).AutoFilter Field:=5, Criteria1:=temp1(J)
 
  'Stop
                          ShTxB.Cells(J + 8, 2) = temp(i)    'VAL4
                          ShTxB.Cells(J + 8, 3) = temp1(J)   'VAL5
                          ShTxB.Cells(J + 8, 4) = temp2(J)   'VAL6
 
                          ShTxB.Cells(J + 8, 5) = WorksheetFunction.Subtotal(101, ShBd.Range("I1:I" & NBd)) 'MOY VAL9
                          ShTxB.Cells(J + 8, 5).NumberFormat = "0"
 
                          ShTxB.Cells(J + 8, 6) = WorksheetFunction.Subtotal(101, ShBd.Range("J1:J" & NBd))  'MOY VAL10
                          ShTxB.Cells(J + 8, 6).NumberFormat = "0"
 
                            ' nouveau filtre pour somme1-somme2
                            .Range("A1:AA" & NBd).AutoFilter Field:=8, Criteria1:="=CPS", _
                          Operator:=xlOr, Criteria2:="=S"
                            a = WorksheetFunction.Subtotal(109, ShBd.Range("O1:O" & NBd))
 
                            .Range("A1:AA" & NBd).AutoFilter Field:=8, Criteria1:="=I", _
                            Operator:=xlOr, Criteria2:="=JI"
                            .Range("A1:AA" & NBd).AutoFilter Field:=11, Criteria1:="="
                                b = WorksheetFunction.Subtotal(109, ShBd.Range("O1:O" & NBd))
 
                                ShTxB.Cells(J + 8, 7) = a - b
 
                                .Range("A1:AA" & NBd).AutoFilter Field:=11
                                .Range("A1:AA" & NBd).AutoFilter Field:=8
 
                            ShTxB.Cells(J + 8, 9) = WorksheetFunction.Subtotal(104, ShBd.Range("G1:G" & NBd)) _
                          - WorksheetFunction.Subtotal(105, ShBd.Range("G1:G" & NBd)) 'max-min filtrer
                             d = ShTxB.Cells(J + 8, 9).Value
 
                            ShTxB.Cells(J + 8, 8) = (a - b) / (WorksheetFunction.Pi() * _
                            (WorksheetFunction.Convert(temp2(J), "in", "m") * d)) 'densité
                            ShTxB.Cells(J + 8, 8).NumberFormat = "0.00"" µA/m²"""
 
                            e = WorksheetFunction.Subtotal(103, ShBd.Range("I1:I" & NBd)) 'nbval filter
 
                            .Range("A1:AA" & NBd).AutoFilter Field:=9, Criteria1:="<=-600"
                            f = WorksheetFunction.Subtotal(103, ShBd.Range("I1:I" & NBd))
                            .Range("A1:AA" & NBd).AutoFilter Field:=9
 
                          ShTxB.Cells(J + 8, 10) = (f / e)
                          ShTxB.Cells(J + 8, 10).NumberFormat = "0%"
                          ShTxB.Cells(J + 8, 11) = "" '
 
                 Next J
            Next i
 
            .AutoFilterMode = False
        End With
 End With
Set ShBd = Nothing
Set ShTxB = Nothing
End Sub

Merci à vous tous. j'attends donc vos réactions avant de clôturer cette discussion.

Cordialement,