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
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.
Je ne sais donc pas ce que tu peux faire pour avoir une erreur...
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 !
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à.
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 !
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.