Copier/Coller Avec condition VBA

Bonjour,

J'ai crée cette boucle qui permet de copier coller avec des conditions mais ça beug ca me crée une page par copier/coller, je veux que ca crée tous le page d'un coup.

Quelqu'un a une idée de comment régler ce problème svp ? Merci

Bonne soirée

UP please

Bonsoir,

Sub FeuillesNom()
    Dim d As Object, k, lst, noms, ws As Worksheet, plg As Range, i&, n%
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare
    With Worksheets("Feuille1")
        If .FilterMode Then .ShowAllData
        Set plg = .Range("A1").CurrentRegion.Resize(, 1)
    End With
    With plg
        For i = 2 To .Rows.Count
            d(.Cells(i, 1).Value) = ""
        Next i
    End With
    lst = d.keys
    noms = Join(lst, ";")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        Select Case ws.Name
            Case "Feuille1"
            Case Else
                ws.Delete
        End Select
    Next ws
    Set ws = Worksheets(1)
    For Each k In d.keys
        n = n + 1
        ws.Copy after:=Worksheets(n)
        With ActiveSheet
            .Name = k
            Set plg = .Range("A1").CurrentRegion
            noms = Replace(Replace(noms, k, ""), ";;", ";")
            noms = Split(noms, ";")
            plg.AutoFilter 1, noms, xlFilterValues
            plg.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
        End With
        noms = Join(lst, ";")
    Next k
    ws.Activate
End Sub

NB- Les anciennes feuilles sont détruites avant création des nouvelles.

Bouton sur Feuille1.

Cordialement.

Bonsoir MFerrand,

Merci pour la reponse mais ca ne marche pas j'ai ca comme message d'erreur : un composant activex ne peut pas créer un objet

vous avez une idee pourquoi ?

Merci

Je pense que le problème vient du fait que je suis sous Mac, vous auriez pas une autre facon pour le faire ?

J'ai retéléchargé le fichier à partir de mon post. Il fonctionne parfaitement, sans rien dire !

Je ne sais donc pas ce que tu peux faire pour avoir une erreur... (à moins de travailler sur MAC, mais je n'ai pas détecté ça dans ton fichier ?)

Le cas échéant, essaie de cocher la référence Microsoft Scripting Runtime.

Cordialement.

edit : Evidemment cette méthode ne fonctionne pas sur MAC ! Si j'avais su ça avant, j'aurais évité d'intervenir...

Il faut convertir le dico en collection, et ça va être un peu moins simple... et je ne vais pas me lancer là-dedans à cette heure, et demain je ne serai sans doute pas disponible pour le faire. Il faudra donc attendre, à moins que quelqu'un te fournisse une autre solution d'ici là.

MFerrand a écrit :

J'ai retéléchargé le fichier à partir de mon post. Il fonctionne parfaitement, sans rien dire !

Je ne sais donc pas ce que tu peux faire pour avoir une erreur... (à moins de travailler sur MAC, mais je n'ai pas détecté ça dans ton fichier ?)

Le cas échéant, essaie de cocher la référence Microsoft Scripting Runtime.

Cordialement.

Je suis sur Mac c'est pour ça, Vous ne auriez pas une autre solution pour le faire ? Je serai tres reconnaissant

Voir edit dans le post précédent.

J'ai trouvé à supprimer le dico sans passer par une collection, avec finalement peu de changement dans le code :

Sub FeuillesNom()
    Dim k, lst, noms, ws As Worksheet, plg As Range, i&, n%
    With Worksheets("Feuille1")
        If .FilterMode Then .ShowAllData
        Set plg = .Range("A1").CurrentRegion.Resize(, 1)
        plg.AdvancedFilter xlFilterCopy, , .Range("ZZ1"), True
        With .Range("ZZ1").CurrentRegion
            For i = 2 To .Rows.Count
                noms = noms & ";" & .Cells(i, 1)
            Next i
            .Clear
        End With
    End With
    noms = Replace(noms, ";", "", 1, 1)
    lst = Split(noms, ";")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        Select Case ws.Name
            Case "Feuille1"
            Case Else
                ws.Delete
        End Select
    Next ws
    Set ws = Worksheets(1)
    For Each k In lst
        n = n + 1
        ws.Copy after:=Worksheets(n)
        With ActiveSheet
            .Name = k
            Set plg = .Range("A1").CurrentRegion
            noms = Replace(Replace(noms, k, ""), ";;", ";")
            noms = Split(noms, ";")
            plg.AutoFilter 1, noms, xlFilterValues
            plg.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
        End With
        noms = Join(lst, ";")
    Next k
    ws.Activate
End Sub

En espérant que cela fonctionne (et que MAC ne nous réserve pas d'autre surprise).

Oh ca marche merci beaucoup, mais je ne comprends pas la logique j'ai jamais codé comme ca ...

Voici une version de fichier vous pouvez le dire comment faire si on a plusieurs tables de donnee en Feuille1 a chaque fois il faut les ajouter dans les feuilles qui corresponds ?

Bonjour,

La logique est tout à fait simple ! Explications de code :

Sub FeuillesNom()
    Dim k, lst, noms, ws As Worksheet, plg As Range, i&, n%
    With Worksheets("Feuille1")
        If .FilterMode Then .ShowAllData
        Set plg = .Range("A1").CurrentRegion.Resize(, 1)
        plg.AdvancedFilter xlFilterCopy, , .Range("ZZ1"), True
        With .Range("ZZ1").CurrentRegion
            For i = 2 To .Rows.Count
                noms = noms & ";" & .Cells(i, 1)
            Next i
            .Clear
        End With
    End With
    noms = Replace(noms, ";", "", 1, 1)
    lst = Split(noms, ";")

Déclarations de variables : rien de spécial à souligner, 3 variables sont non typées (type Variant) parce que le type de valeurs qu'elles accueillent changera.

Dans cette première partie, on se cible sur la feuille source (Feuille1) : étant susceptible d'être filtrée, on s'assure de défiltrer s'il y a lieu (si le filtre est actif), puis on affect à notre variable Range (pour faciliter la manipulation ultérieure de la plage) la 1re colonne contenant les noms devant générer des feuilles distinctes (l'utilisation de CurrentRegion, quand on le peut, permet de se dispenser de chercher la dernière ligne pour dimensionner une plage).

On applique un filtre avancé à cette 1re colonne pour produire une extraction unique des noms qu'elle contient. On place cette extraction temporaire dans un endroit éloigné, hors de vue, en ZZ1 (qui ne risque guère d'être atteint par le tableau de données).

On dispose donc à cet endroit d'une liste de noms uniques, nos noms de feuilles à créer, que l'on va recueillir en parcourant la liste à partir de la ligne 2 (en-tête en ligne 1).

Ce recueil se fait d'abord sous forme de chaîne (texte) d'éléments que l'on sépare par des points-virgules.

On en supprime le 1er point-virgule de façon que la chaîne débute par un nom, puis on splitte (transforme la chaîne en tableau sur la base du séparateur point-virgule). On dispose donc de la liste d'une part sous forme de chaîne (variable noms), d'autre part sous forme de tableau (variable lst). On verra pourquoi par la suite.

On élimine notre extraction temporaire des noms en ZZ1.

On peut maintenant passer à la génération des feuilles.

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        Select Case ws.Name
            Case "Feuille1"
            Case Else
                ws.Delete
        End Select
    Next ws
    Set ws = Worksheets(1)

On va commencer par éliminer toute feuille existante (sauf Feuille1, la feuille source, bien sûr) de façon à opérer sur une situation nettoyée. On désactive préalablement les messages d'alerte (pour supprimer les feuilles) et la mise à jour de l'affichage (d'autant qu'ensuite en générant des feuilles on se trouvera en permanence sur la feuille active...). On affecte la feuille source (la seule qui reste) à notre variable Worksheet.

    For Each k In lst
        n = n + 1
        ws.Copy after:=Worksheets(n)
        With ActiveSheet
            .Name = k
            Set plg = .Range("A1").CurrentRegion
            noms = Replace(Replace(noms, k, ""), ";;", ";")
            noms = Split(noms, ";")
            plg.AutoFilter 1, noms, xlFilterValues
            plg.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
        End With
        noms = Join(lst, ";")
    Next k
    ws.Activate
End Sub

Pour générer nos feuilles, on va tout bêtement parcourir notre tableau lst : chaque élément de ce tableau constitue un nom de nouvelle feuille.

NB- On peut parcourir un tableau, dans les mêmes conditions qu'une Collection, au moyen d'une boucle For Each... Next, la variable de boucle (ici k) devant alors être obligatoirement de type Variant.

A chaque tour de boucle :

- on incrémente une variable Integer, de façon qu'elle donne le rang de la dernière feuille existante dans le classeur (au démarrage, la 1re incrémentation se fait de 0 à 1, et seule la feuille source est présente, ayant nécessairement le rang 1) ;

- on crée une copie de la feuille source, que l'on place à la suite (et qui devient automatiquement la feuille active) ;

- on nomme cette feuille active par l'élément atteint dans la boucle ;

• puis on élimine de notre variable noms (liste des noms sous forme de chaîne) le nom de l'élément traité (et nom de la feuille) et on transforme la liste en tableau (Split), que l'on utilise comme critère de filtrage : les lignes contenant le nom de la feuille en 1re colonne seront donc masquées, et tous les autres noms visibles...
• on supprime en une seule fois toutes les lignes visibles du tableau (sauf l'en-tête), puis on réaffiche les lignes masquées : seules les lignes au nom voulu demeurent ;
• on rétablit notre chaîne de noms complète avant de passer au traitement de la feuille suivante.

Cordialement.

Merci beaucoup pour ces explications,

j'aimerai savoir comment faire si on a plusieurs tables dans feuille1 pour réaliser un copier coller dans les feuilles crées sans Cr1, cr2 et CR3 mais que les valeurs en face de chaque lettre.

Voici le fichier pour comprendre.

Merci

La disposition n'est pas adéquate. Il faut rétablir les données sous forme base de données (champs=colonnes, enregistrements=lignes)...

Une telle disposition n'étant nécessité par rien, je demeure opposé aux exercices de gymnastiques gratuits, c'est la disposition des données qu'il convient de modifier.

Cordialement.