Optimiser l'export des données vers d'autres feuilles

bonjour la communauté Excel-Pratique,

Je voudrais solliciter votre aide car je fais face à un soucis dont je n'arrive pas à solutionner le problème.

A l'exécution de ma macro, l'action de ma macro met beaucoup de temps à finaliser son exécution.

Pourtant mon code est assez simple mais je ne sais pas comment je pourrais optimiser ma macro pour avoir une action presque instantanée.

Pour info: la macro est sensée créer des sheets dans mon classeur s'ils n’existent pas. Puis importer dans ces feuilles créées les données qui se trouvent sur la feuille principale en supprimant les données de la feuille principale une fois exportées.

Voici le code

Sub Newsheet()
Dim n As Integer
Dim trouve As Boolean
MotCle = Array("01", "02")
For i = Empty To UBound(MotCle)
For n = 1 To Sheets.Count
If Sheets(n).Name = MotCle(i) Then
  trouve = True
  Exit For
End If
Next n
If Not trouve Then Sheets.Add.Move After:=Sheets(Sheets.Count)
Worksheets(Sheets.Count).Name = MotCle(i)
Next i
'.........
Call ActionCut
End Sub
Sub ActionCut()
Dim MotCle
Dim i As Byte
Dim C As Range
Dim F As String
Dim Ligne As Long
    'On définit les mots clés
    MotCle = Array("01", "02")
    F = MotCle(i)
    'On effectue la recherche de chaque mot clé dans la colonne A de la sheet Main
    For i = Empty To UBound(MotCle)
        Do
            Set C = Worksheets("Main").Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
            'Si le mot clé est trouvé

            If Not C Is Nothing Then
            F = (MotCle(i))
                'On définit le nom de la feuille où sera effectuée la copie
                With Worksheets(F)
                    'On définit la ligne où sera effectué le collage
                    Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    'On effectue le copier / coller
                    C.EntireRow.Copy .Range("A" & Ligne)
                    'On supprime la ligne dans la sheet Main
                    C.EntireRow.Delete
                End With
                End If
        Loop While Not C Is Nothing
    Next i
End Sub

Bonjour

Une proposition

Il faut une feuille "Main" présentée comme dans ton exemple.

Sub Efge_1()
Dim TData As Variant, Tdata1 As Variant, Tdata2 As Variant, sh As Worksheet
Dim i&, j&, Rw1&, Rw2&, RwData&
Dim Rng As Range, tst$
Dim Flag As Boolean

With Sheets("Main")
    Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3)(1, 13))
End With

TData = Rng: Tdata1 = Rng: Tdata2 = Rng

For i = LBound(TData, 1) To UBound(TData, 1)
    Flag = False
    tst = Left(TData(i, 1), 3)
    On Error Resume Next
    Set sh = ThisWorkbook.Worksheets(tst)
    If Err Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = tst
        Err.Clear
    Else
        Sheets(tst).ClearContents
    End If
    Select Case tst
        Case "01."
            Rw1 = Rw1 + 1
            For j = LBound(TData, 2) To LBound(TData, 2)
                Tdata1(Rw1, j) = TData(i, j)
            Next j
            Flag = True
        Case "02."
            Rw2 = Rw2 + 1
            For j = LBound(TData, 2) To LBound(TData, 2)
                Tdata1(Rw2, j) = TData(i, j)
            Next j
            Flag = True
    End Select
    If Flag = False Then
        RwData = RwData + 1
        For j = LBound(TData, 2) To UBound(TData, 2)
            TData(RwData, j) = TData(i, j)
        Next j
    End If
Next i
Sheets("01.").Cells(1, 1).Resize(Rw1, UBound(TData, 2)) = Tdata1
Sheets("02.").Cells(1, 1).Resize(Rw2, UBound(TData, 2)) = Tdata2
With Rng
    .ClearContents
    .Cells(1, 1).Resize(RwData, UBound(TData, 2)) = TData
End With
End Sub

Cordialement

Bonjour Efge,

Merci beaucoup pour cette proposition.

Je débute un peu en VB et j'aurais une question. Dans ton code je dois renseigner les feuilles qui seront crées mais s'il existe 50 feuilles à créer il est assez pénible de faire un [Select Case] pour les 50.

J'aimerais ne pas avoir à renseigner quoique ce soit dans le code hormis les Mots clés (qui dans ton cas sont les 3 premiers caractères de chaque cellules).

Merci beaucoup.

Abakisi

Bonjour

Avec ceci, je passe de 1 minute 10 avec ton code à 9 secondes (ce qui reste long)

Il faut que la liste des codes commence et finisse par une virgule.

Sub Efge_2()
Dim i&, LstRw, tst$, Liste$, LstCol&
Dim sh As Worksheet, ShData As Worksheet
Set ShData = Sheets("Main")

With ShData
    LstRw = .Cells(.Rows.Count, 1).End(3).Row
    LstCol = .Cells(1, .Columns.Count).End(1).Column
End With
Liste = ",01,02,"

Application.ScreenUpdating = False
For i = LstRw To 1 Step -1
    tst = Left(ShData.Cells(i, 1), 2)
    If InStr(Liste, "," & tst & ",") > 0 Then
        On Error Resume Next
        Set sh = ThisWorkbook.Worksheets(tst)
        If Err Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = tst
            Err.Clear
        End If
        With Sheets(tst)
            ShData.Cells(i, 1).Resize(, LstCol).Copy .Cells(.Rows.Count, 1).End(3)(2).Resize(, LstCol)
        End With
        ShData.Rows(i).Delete
    End If
Next i
Application.ScreenUpdating = True
End Sub

Cordialement

Merci Efgé,

C'est déjà une très grosse progression sur la performance de base.

Mais par contre j'ai un peu du mal à interpréter ton code.

Je voudrais l'adapter et ajouter d'autres feuilles ainsi que changer le contenu de la liste mais cela semble ne pas marcher.

Pourrais tu commenter quelques lignes essentielles à la compréhension de ton code?

Encore fois Merci de ton aide.

Abakisi

Re

Voici une version commentée du code.

C'est une variante qui fait passer le temps de traitement à +/- 4,5 secondes.

Cordialement

Bonjour,

une alternative en copiant par bloc contigu, ce qui améliore les performances.

Merci beaucoup chers amis du Forum

vos propositions fonctionnent parfaitement.

Encore quelques soucis à adapter le code à n'importe quel fichier mais solution est déjà là.

Merci beaucoup.

Bonjour à tous

Pour l'exercice, j'ai fait un tableau à trois dimensions.

La création et export sur 38 feuilles prend +/- 0,7 seconde.

Le code est commenté.

Cordialement

Bonjour Efgé,

Merci beaucoup pour ta solution elle marche à fond.

J'aurais juste une ou deux questions... Pourquoi avoir procédé en créant un tableau à 3 dimensions?

Quel est l'avantage de cette solution par rapport à la précédente qui était de créer une simple liste ou une simple table?

Merci d'avance pour ta réponse et encore merci pour cette solution.

PS: Comment pourrait-on extraire les données en concevant la mise en page des cellules et de la feuille comme appliquée sur la feuille"Main"? -- Voir l'exemple en pièce jointe.

Bien à toi,

Abakisi

Bonjour à tous, le fil, le forum,

abakisi a écrit :

... Pourquoi avoir procédé en créant un tableau à 3 dimensions?

Quel est l'avantage de cette solution par rapport à la précédente qui était de créer une simple liste ou une simple table?

Cette solution répondait, en partie, à la question de base qui était "optimiser l'export de données".

En utilisant la troisième dimension, on peux créer dynamiquement plusieurs tableaux de mêmes dimensions en lignes et colonnes ce qui , sur le sujet qui nous intéresse, est un avantage puisque l'on ne connait pas le nombre de tableaux indépendants à créer.

En utilisant des tableaux on gagne toujours du temps sur l'utilisation permanente des onglets du classeur.

Le seul moment ou on "touche" au classeur est lors de la restitution des données.

abakisi a écrit :

PS: Comment pourrait-on extraire les données en concevant la mise en page des cellules et de la feuille comme appliquée sur la feuille "Main"? -- Voir l'exemple en pièce jointe.

Là, par contre cette méthode n'est pas envisageable.

Les tableaux ne travaillent que sur des données.

Remettre en couleur des cellules implique de travailler directement sur les onglets et donc de perdre tous le gain de temps.

Ta question reviens soit à copier-coller les lignes d'un onglet à un autre (ton premier code qui prend 1Minute 10 pour deux onglets)soit à passer par ma méthode (0,7 seconde pour 38 onglets) ET à re-traiter les 92 053 cellules de ton exemple initial (imagine le temps que l'on perd à nouveau....)

Si quelqu'un voit une solution rapide ça m'intéresse

Cordialement

Efgé a écrit :

Bonjour à tous, le fil, le forum,

abakisi a écrit :

... Pourquoi avoir procédé en créant un tableau à 3 dimensions?

Quel est l'avantage de cette solution par rapport à la précédente qui était de créer une simple liste ou une simple table?

Cette solution répondait, en partie, à la question de base qui était "optimiser l'export de données".

En utilisant la troisième dimension, on peux créer dynamiquement plusieurs tableaux de mêmes dimensions en lignes et colonnes ce qui , sur le sujet qui nous intéresse, est un avantage puisque l'on ne connait pas le nombre de tableaux indépendants à créer.

En utilisant des tableaux on gagne toujours du temps sur l'utilisation permanente des onglets du classeur.

Le seul moment ou on "touche" au classeur est lors de la restitution des données.

abakisi a écrit :

PS: Comment pourrait-on extraire les données en concevant la mise en page des cellules et de la feuille comme appliquée sur la feuille "Main"? -- Voir l'exemple en pièce jointe.

Là, par contre cette méthode n'est pas envisageable.

Les tableaux ne travaillent que sur des données.

Remettre en couleur des cellules implique de travailler directement sur les onglets et donc de perdre tous le gain de temps.

Ta question reviens soit à copier-coller les lignes d'un onglet à un autre (ton premier code qui prend 1Minute 10 pour deux onglets)soit à passer par ma méthode (0,7 seconde pour 38 onglets) ET à re-traiter les 92 053 cellules de ton exemple initial (imagine le temps que l'on perd à nouveau....)

Si quelqu'un voit une solution rapide ça m'intéresse

Cordialement

Bonjour Efgé,

Merci encore pour ces explications. Je comprends mieux la notion des tableaux à 3 dimensions.

Pour le format, j'ai trouvé une solution. ¨Pas très académique mais ça marche tout aussi bien.

Il suffit d'ajouter une boucle qui réalise un collage spécial de toutes les cellules de la feuille "Main" vers les autres feuilles générées.

MotCle = Array("01", "02", "...")
    For i = Empty To UBound(MotCle)

        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name = MotCle(i) Then
            Sheets("Main").Cells.Copy
                With Sh
                    .Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                        SkipBlanks:=False, Transpose:=False
                End With
            End If
        Next Sh
    Next i