Discussion :

[Invité]

Bonjour,

J'ai pu constaté sur des fichiers exemples téléchargés sur le net que l'utilisation des tableaux VBA accélérée notablement l’exécution d'une macro.
Débutant en VBA, je sèche. Et, je ne sais même pas si les tableaux sont adaptés à mon fichier.
Sur un autre fichier (codé par Robert que je remercie), j'ai un exemple de tableau (Array) alimenter par un "Dictionnaire" (Inadapté pour ce cas).

Voilà, j'ai reçu une base de données (32000 lignes*23 colonnes). Pour effectuer des calculs, des graphes et relever les anomalies (défauts).
Je dois extraire les données qui m’intéresse sur une autre feuille pour les traiter.

Pourriez-vous me donner un coup de main, je vous en remercie par avance.

NB: pour des raisons de confidentialités, j'ai modifié les données et supprimé beaucoup de lignes (je n'en ai laissé que 312),
mais je n'ai pas touché à la structure de base de données.

PS: Les explications se trouvent en feuill2 du fichier joint.

Cordialement,
Cathodique

[mercatog]

Bonjour
Une proposition

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
Option Explicit
 
Sub Traitement()
Dim LastLig As Long, i As Long, j As Long
Dim Dte As Long, Val4 As String, Val5 As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Worksheets("BD")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:W" & LastLig)
End With
 
With Worksheets("Calcul")
    Dte = CLng(.Range("B1"))
    Val4 = .Range("F1")
    Val5 = .Range("J1")
    For i = 1 To LastLig - 1
        If CLng(Tb(i, 3)) = Dte And Tb(i, 4) = Val4 And Tb(i, 5) = Val5 Then
            j = j + 1
            Transfer Tb, i, Res, j
        End If
    Next i
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If LastLig > 10 Then .Range("A10:L" & LastLig).ClearContents
    If j > 0 Then .Range("A10").Resize(j, 12) = Application.Transpose(Res)
End With
End Sub
 
 
Private Sub Transfer(ByVal Sce, ByVal n As Long, ByRef Des, ByVal m As Long)
Dim k As Byte
 
ReDim Preserve Des(1 To 12, 1 To m)
Des(1, m) = m
 
For k = 2 To 5
    Des(k, m) = Sce(n, k - 1)
    If k < 5 Then Des(k + 8, m) = Sce(n, k + 3)
Next k
End Sub

[Invité]

Bonjour Mercatog,

Je suis impardonnable et je t'ai induit en erreur. J'ai rajouté bêtement des entêtes sur mon petit tableau de correspondance.
En fait, ce sont les correspondances de colonnes. Ton code semble fonctionner, ce sont les références qui ne sont pas bonnes. Toutes mes excuses.
Col feuil BD..........G..... H.....I.....J.....O.....P.....Q
Col feuil Calcul..... B.....C.....D.....E.....J.....K.....L

Je t'avoue que je n'ai rien compris. As-tu utilisé des tableaux?
Mystère et boule de gomme, je me suis pris la tête à chercher une solution avec des filtres.
N'ayant pas tout compris, je ne pourrais pas modifier ton code pour remettre les colonnes dans le bon ordre.

Serait-il possible d'englober tout le code dans une seule procédure (1 seule macro)? Je verrais peut-être plus clair.

Je te remercie pour ta célérité de ton intervention et ainsi que pour ta précieuse aide.
Je m'excuse encore une fois de t'avoir induit en erreur.


Cordialement,

[mercatog]

Voilà comme désiré.

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
Sub Traitement()
Dim LastLig As Long, i As Long, j As Long
Dim Dte As Long, Val4 As String, Val5 As String
Dim Tb, Res()
Dim k As Byte
 
Application.ScreenUpdating = False
'Dans la variable tableau Tb on récupère toutes les données de la feuille BD
With Worksheets("BD")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:W" & LastLig)
End With
 
With Worksheets("Calcul")
    'ici les 3 critères
    Dte = CLng(.Range("B1"))
    Val4 = .Range("F1")
    Val5 = .Range("J1")
    'on parcours le tableau Tb et si la ligne correspond aux 3 critères
    For i = 1 To LastLig - 1
        If CLng(Tb(i, 3)) = Dte And Tb(i, 4) = Val4 And Tb(i, 5) = Val5 Then
            'on incrémente le compteur j (nombre de lignes trouvées)
            j = j + 1
            'On redimensionne notre tableau Resultat (12 lignes et j colonnes) Res sera transposé à la fin car on ne peut redimenssionner que la dernière dimension
            ReDim Preserve Res(1 To 12, 1 To m)
            'Le compteur est inscrit en 1ère ligne
            Res(1, m) = m
            'on fait une petite boucle
            'Col 1 vers ligne 2
            'Col 2 vers ligne 3
            'Col 3 vers ligne 4
            'Col 4 vers ligne 5
            'Col 15 vers ligne 10
            'Col 16 vers ligne 11
            'Col 17 vers ligne 12
 
            For k = 2 To 5
                Res(k, m) = Tb(n, k - 1)
                If k < 5 Then Res(k + 8, m) = Tb(n, k + 13)
            Next k
        End If
    Next i
    'on efface la plage de Calcul
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If LastLig > 10 Then .Range("A10:L" & LastLig).ClearContents
    'on transfère le transposé de Res
    If j > 0 Then .Range("A10").Resize(j, 12) = Application.Transpose(Res)
End With
End Sub

Autre chose?

[Invité]

C'est très sympa de ta part. Mais j'ai un bug code d'erreur '9', l'indice n'appartient pas à la sélection à la ligne suivante:

ReDim Preserve Res(1 To 12, 1 To m)

** je te rappelle que le transfert commence en B10 et non en A10 sur la feuille "Calcul". Désolé.

Que faire?

Je te remercie aussi d'avoir commenté le code.

Cordialement,

[mercatog]

Oups

Excuse moi, à la dernière minute j'ai fusionné les 2 codes à la hâte

Remplace m par j et n par i


EDIT
***

** je te rappelle que le transfert commence en B10 et non en A10 sur la feuille "Calcul". Désolé.