Améliorer et accélérer une procédure par l'utilisation de var tableau

Le 15/02/2021 à 16:07

Bonjour à tous,

Je souhaite remplacer une procédure qui recopie des données contenues dans des colonnes en faisant une recherche sur le nom du champ, par une procédure qui passerait par une variable tableau afin d'optimiser, d'accélérer et de me permettre de progresser en vba ;-)

Le nombre de lignes peut être largement supérieur au fichier joint. La durée de traitement peut donc être très supérieure.

Merci d'avance pour l'aide que vous voudrez bien m'apporter.

Cordialement,
Dan

9tableau-donnees.zip (223.35 Ko)
Option Explicit

Dim ColFinLettre As String
Dim F_Source, F_Travail, F_Liste_Champs As Worksheet

Sub test()
    Dim Nb_Champs_Source, NoCol As Integer
    Dim DerLig_F_Source As Long, DerLig_F_Travail As Long
    Dim AdresseTrouvee As String, CL As String, NCol As String, NLigne As String
    Dim Var, NomCol, CelArv As Variant
    Dim PlgDonneesSource As Variant
    Dim Trouve As Range, PlageDeRecherche As Range
    Dim DerLg_Donnees_Source As Long, i As Long
    Dim PlgRecherche As Range
    Dim NoLig As Long
    Dim start As Single

    Application.ScreenUpdating = False

    start = Timer
    Set F_Source = Worksheets("Donnees_Source")
    Set F_Travail = Worksheets("Donnees_Travail")
    Set F_Liste_Champs = Worksheets("Liste_Champs")

    ' Comptage du nombre de champs de l'onglet source
    Nb_Champs_Source = F_Source.Range("A1").SpecialCells(xlCellTypeLastCell).Column

    DerLig_F_Source = F_Source.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_F_Travail = F_Travail.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row

    NoLig = 1

    For NoCol = 1 To Nb_Champs_Source
        F_Source.Select
        Var = F_Source.Cells(NoLig, NoCol)
        CL = ColLettre(NoCol)

        PlgDonneesSource = Range(CL & "2" & ":" & CL & DerLig_F_Source).Select
        Set PlgDonneesSource = Range(CL & "2" & ":" & CL & DerLig_F_Source)

        ' Passage sur la feuille Donnees_SINP
        F_Travail.Select
        ' Cherche le nom de la colonne
        Set PlageDeRecherche = ActiveSheet.Rows(12)
        On Error Resume Next
        Set Trouve = PlageDeRecherche.Cells.Find(What:=Var, LookAt:=xlWhole)
        AdresseTrouvee = Trouve.Address
        If Trouve = "Nothing" Or Trouve = "" Then
            Application.ScreenUpdating = True

            End
        End If

        ' Récupération de la colonne pour copier les données
        NCol = Split(AdresseTrouvee, "$")(1)
        ' Récupération de la ligne pour copier les données
        NLigne = Split(AdresseTrouvee, "$")(2) + 1
        Set CelArv = Range(NCol & NLigne)
        PlgDonneesSource.Copy CelArv
    Next
    Application.ScreenUpdating = True
    MsgBox "Copie terminée - Durée du traitement : " & Timer - start & " secondes"
End Sub

Sub Nettoyage()
    Dim DerLig_F_Travail As Long
    Dim DerCol_F_Travail As Integer
    Dim DerColL_F_Travail As String

    Set F_Travail = Worksheets("Donnees_Travail")
    F_Travail.Select
    DerLig_F_Travail = F_Travail.Range("B" & Rows.Count).End(xlUp).Row

    DerCol_F_Travail = F_Travail.Range("B12").SpecialCells(xlCellTypeLastCell).Column
    DerColL_F_Travail = ColLettre(DerCol_F_Travail)

    If DerLig_F_Travail > 12 Then
        Range("B13:" & DerColL_F_Travail & DerLig_F_Travail).ClearContents
    End If
End Sub

Function ColLettre(col)
    ColLettre = Split(Cells(1, col).Address, "$")(1)
    ColFinLettre = ColLettre
End Function
Le 15/02/2021 à 16:30

Bonjour Dan,

Pour bien comprendre le sujet ... tu souhaites en fait ne conserver de Donnees_Source que les colonnes dont l'en-tête se trouve dans la Liste_Champs, c'est bien cela ?

On peut le faire simplement par recopie globale et suppression de colonnes !

Mais on peut aussi le faire en array en effet. Merci de confirmer que j'ai bien saisi ton sujet.

Le 15/02/2021 à 17:28

Bonjour Steelson,

Merci pour l'intérêt à mon problème.
L'idée est de copier les données situées sur la feuille "Donnees_Source" sur la feuille "Donnees_Travail" en conservant tous les autres champs de la feuille "Donnees_Travail", car ceux-ci pourraient être renseignés par des données futures.

Dans ce cas précis, seules les données dont les champs figurent sur la feuille Liste_Champs" doivent être transférées (ce qui correspond en fait aux seules colonnes contenant des donnée).

C'est une procédure qui comporte des tas d'autres macros (avant et après ce traitement). Il y a auparavant des suppressions de colonnes vides, des contrôles de données en tout genre...
C'est un peu complexe à expliquer, c'est pourquoi j'ai fait une copie partielle des 3 feuilles concernées pour l'exemple.

L'idée est vraiment de le faire en array afin d'accélérer le traitement et de me permettre d'en comprendre le principe.

Merci encore et à bientôt peut-être

Dan

Le 15/02/2021 à 17:52
Dan67100 a écrit :

seules les données dont les champs figurent sur la feuille Liste_Champs" doivent être transférées (ce qui correspond en fait aux seules colonnes contenant des donnée).

Voici une proposition

Option Explicit
Sub extraire()
Dim champs, donnees, col%, lig%, start, i%, j%, indic As Boolean, nbcol%

    start = Timer
    champs = Sheets("Liste_Champs").Range("B2").CurrentRegion
    donnees = Sheets("Donnees_source").Range("A1").CurrentRegion
    nbcol = 0
    For col = UBound(donnees, 2) To 1 Step -1
        ' l'en-tête fait-elle partie de la liste ?
        indic = False
        For i = 2 To UBound(champs, 1)
            If champs(i, 1) = donnees(1, col) Then indic = True: Exit For
        Next
        ' si elle n'en fait pas partie ...
        If Not indic Then
            If col < UBound(donnees, 2) Then
                For i = 1 To UBound(donnees, 1)
                    For j = col + 1 To UBound(donnees, 2) - nbcol
                        donnees(i, j - 1) = donnees(i, j)
                    Next
                Next
            End If
            nbcol = nbcol + 1
        End If
    Next
    Sheets("Resultat").Cells.Clear
    Sheets("Resultat").Range("A1").Resize(UBound(donnees, 1), UBound(donnees, 2) - nbcol) = donnees
    MsgBox "Copie terminée - Durée du traitement : " & Timer - start & " secondes"

End Sub
8tableau-donnees.xlsm (208.11 Ko)
Le 15/02/2021 à 18:19

Merci Steelson pour ce travail.
Je n'ai pas été tout à fait clair dans ma description.

La totalité des champs doit être conservé sur la feuille "Donnees_Travail", y compris les champs vides, car pour d'autres jeux de données, certains d'entres-eux seront renseignés.
Il est aussi nécessaire de conserver l'ordre dans lequel ils sont affichés, c'est pour ça que je les positionnais ligne 12 à partir de la colonne B, car dans mon fichier complet c'est de cette façon qu'ils sont présentés.

Le travail en array est super efficace !

Encore merci pour cette proposition et je suis preneur des modifications éventuelles (mais sans urgence).

Dan

Le 15/02/2021 à 18:39

C'est donc plus simple

Option Explicit
Sub extraire()
Dim champs, donnees, col%, lig%, start, i%, j%, indic As Boolean

    start = Timer
    champs = Sheets("Liste_Champs").Range("B2").CurrentRegion
    donnees = Sheets("Donnees_source").Range("A1").CurrentRegion
    For col = UBound(donnees, 2) To 1 Step -1
        ' l'en-tête fait-elle partie de la liste ?
        indic = False
        For i = 2 To UBound(champs, 1)
            If champs(i, 1) = donnees(1, col) Then indic = True: Exit For
        Next
        ' si elle n'en fait pas partie ...
        If Not indic Then
            For i = 2 To UBound(donnees, 1)
                donnees(i, col) = ""
            Next
        End If
    Next
    Sheets("Resultat").Cells.Clear
    Sheets("Resultat").Range("B12").Resize(UBound(donnees, 1), UBound(donnees, 2)) = donnees
    MsgBox "Copie terminée - Durée du traitement : " & Timer - start & " secondes"

End Sub

sauf si j'ai encore compris de travers (n'hésite pas à me reprendre)

7tableau-donnees.xlsm (306.55 Ko)
Le 15/02/2021 à 19:07

Presque !

Il faudrait juste que la ligne 12 ne soit pas concernée par la recopie, car cette ligne comporte des couleurs en fonction de la valeur (obligatoire, conditionnelle...) de certains champs (je ne l'ai pas précisé dans ma demande initiale - désolé).

Sinon, c'est vraiment top !

J'ai toujours beaucoup de mal à comprendre comment on peut réduire le code à quelques lignes et qu'en plus ça marche mieux !
Je vais essayer de bien comprendre ce que tu as fait pour la suite...

Merci

Dan

Le 15/02/2021 à 19:10
Dan67100 a écrit :

Presque !

Il faudrait juste que la ligne 12 ne soit pas concernée par la recopie, car cette ligne comporte des couleurs en fonction de la valeur (obligatoire, conditionnelle...) de certains champs (je ne l'ai pas précisé dans ma demande initiale - désolé).

hé bien, à toi de le faire, tu devrais y arriver ... chiche !

Le 15/02/2021 à 19:13

Je vais essayer, mais j'ai remarqué que lorsqu'il faut ajouter une ligne, j'ajoute un pâté

Le 15/02/2021 à 21:56

Tu as présumé de mes capacités !

Je parviens à mes fins, mais de quelle manière !

Je suis bien sûr preneur de ta solution Steelson (en te remerciant par avance).

Bonne soirée (si tu es encore sur ton pc)

Dan

Option Explicit
Sub extraire()
Dim champs, donnees, col%, lig%, start, i%, j%, indic As Boolean
Dim DerLig As Long

    start = Timer
    champs = Sheets("Liste_Champs").Range("B2").CurrentRegion
    donnees = Sheets("Donnees_source").Range("A1").CurrentRegion
    For col = UBound(donnees, 2) To 1 Step -1
        ' l'en-tête fait-elle partie de la liste ?
        indic = False
        For i = 2 To UBound(champs, 1)
            If champs(i, 1) = donnees(1, col) Then indic = True: Exit For
        Next
        ' si elle n'en fait pas partie ...
        If Not indic Then
            For i = 2 To UBound(donnees, 1)
                donnees(i, col) = ""
            Next
        End If
    Next

    Sheets("Resultat").Select
    On Error Resume Next
    DerLig = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    Rows(14 & ":" & DerLig).ClearContents
    Sheets("Resultat").Range("B13").Resize(UBound(donnees, 1), UBound(donnees, 2)) = donnees
    Rows("13:13").Delete Shift:=xlUp
    MsgBox "Copie terminée - Durée du traitement : " & Timer - start & " secondes"

End Sub
Le 16/02/2021 à 03:26

C'est pas mal du tout !

Alors une version stricte en array (et juste pour éviter la suppression de la ligne 13) avec un tableau d'entêtes (en réalité tout le tableau dont je ne me sers que de la première ligne) et un tableau de données (tout le tableau décalé de 1 ligne)

Option Explicit
Sub extraire()
Dim champs, entetes, donnees, col%, lig%, start, i%, j%, indic As Boolean

    start = Timer
    champs = Sheets("Liste_Champs").Range("B2").CurrentRegion
    entetes = Sheets("Donnees_source").Range("A1").CurrentRegion
    donnees = Sheets("Donnees_source").Range("A1").CurrentRegion.Offset(1, 0)
    For col = UBound(entetes, 2) To 1 Step -1
        ' l'en-tête fait-elle partie de la liste ?
        indic = False
        For i = 2 To UBound(champs, 1)
            If champs(i, 1) = entetes(1, col) Then indic = True: Exit For
        Next
        ' si elle n'en fait pas partie ...
        If Not indic Then
            For i = 1 To UBound(donnees, 1)
                donnees(i, col) = ""
            Next
        End If
    Next
    Sheets("Resultat").Range("A12").CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Resultat").Range("B13").Resize(UBound(donnees, 1), UBound(donnees, 2)) = donnees
    MsgBox "Copie terminée - Durée du traitement : " & Timer - start & " secondes"

End Sub
Le 16/02/2021 à 04:52

Bonjour,

Une proposition Power Query qui ne demande pas de compétences particulières.

Des explications sont fournies dans le fichier joint.

Si l'origine des données est un fichier csv ou txt, la procédure est +/- équivalente.

Cdlt.

13tableau-donnees.xlsx (238.10 Ko)
Le 16/02/2021 à 16:01

Top !
Merci Steelson pour le temps passé, ta réactivité et tes explications,
Tout est OK est fonctionne super bien.
Il faut vraiment que je passe un peu de temps pour essayer de bien comprendre ton code.

Merci beaucoup Jean-Eric pour les explications détaillées sur la manière de faire avec Power Query,
C'est vraiment sympa !
Je note cette possibilité que je ne connaissais pas et qui semble accessible.
Merci encore
Dan

Rechercher des sujets similaires à "ameliorer accelerer procedure utilisation var tableau"