XL 2013 Ajouter sur quatre feuilles

maval

maval

XLDnaute Barbatruc
Bonjour

J'ai dans une feuille une liste de 3 noms dans la cellule "E", j'ai un code qui sépare les trois noms et qui les transposes dans la colonne "A" jusqu'ici tous vas bien.
J'aimerais que lorsque j'ajoute dans la feuille nommé "Données" une liste de 3 noms dans une des cellule "E" sa les ajoute dans les quatre feuilles "BdD Acteurs, Filmographie, Récompenses, Biographie" dans la colonne "A"

Si possible?

Je vous remercie d'avance
 

Pièces jointes

  • ajouter-automatiquement-dans-plusieurs-feuilles.xlsm
    22.2 KB · Affichages: 46
Trier par date Trier par votes
DoubleZero

DoubleZero

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Bonjour, maval, le Forum,

Comme ceci ?

Code: 
Sub Séparer()
    Dim Cel As Range
    Dim DEST As Range
    Dim o As Object    ' ajouter
    Application.ScreenUpdating = False
    For Each Cel In Range("E2:E" & Cells(Application.Rows.Count, 5).End(xlUp).Row)
        If UBound(Split(Cel.Value, ",")) > 0 Then
            For i = 0 To UBound(Split(Cel.Value, ","))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ",")(i))
            Next i
        Else
            For i = 0 To UBound(Split(Cel.Value, ";"))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ";")(i))
            Next i
        End If
    Next Cel
    ' ajouter
    For Each o In Worksheets(Array("BdD Acteurs", "Filmographie", "Récompenses", "Biographie"))
        Sheets("Données").Columns(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Copy Destination:=o.Range("a1")
    Next
    Application.ScreenUpdating = True
End Sub

A bientôt :)
 
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Bonjour Doublezero,

Je te remercie beaucoup seul bémol c'est que sa recopie à chaque fois toute la liste, alors qu'il serai bien qu'il rajoute uniquement les noms ajoutés à la colonne "E"

A bientôt
 
Vote positif 0 Vote négatif
DoubleZero

DoubleZero

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Re-bonjour,

maval à dit:
... sa recopie à chaque fois toute la liste, alors qu'il serai bien qu'il rajoute uniquement les noms ajoutés à la colonne "E"...
Cliquez pour agrandir...

Certes... Mais c'est le produit de la macro originale pour l'onglet "Données" (copie des valeurs les unes sous les autres, sans suppression préalable).

Nouvel essai :

Code: 
Sub Séparer_v2()
    Dim Cel As Range
    Dim DEST As Range
    ' ajouter
    Dim o As Object
    Application.ScreenUpdating = False
    ' ajouter
    Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row).Clear
    For Each Cel In Range("E2:E" & Cells(Application.Rows.Count, 5).End(xlUp).Row)
        If UBound(Split(Cel.Value, ",")) > 0 Then
            For i = 0 To UBound(Split(Cel.Value, ","))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ",")(i))
            Next i
        Else
            For i = 0 To UBound(Split(Cel.Value, ";"))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ";")(i))
            Next i
        End If
    Next Cel
    ' ajouter
    For Each o In Worksheets(Array("BdD Acteurs", "Filmographie", "Récompenses", "Biographie"))
        Sheets("Données").Columns(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Copy Destination:=o.Range("a1")
    Next
    Application.ScreenUpdating = True
End Sub

A bientôt :)
 
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Re,

Oui sa roule, je vais t'embêter un petit peu si tu le permet je viens de m'apercevoir si cela est possible de mettre la liste en ordre alpha et supprimer les doublons SVP.
Je te remercie et te souhaite un bon WE
 
Vote positif 0 Vote négatif
DoubleZero

DoubleZero

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Re-bonjour,

Une nouvelle version...

Code: 
Sub Séparer_v3()
    Dim Cel As Range
    Dim DEST As Range
    ' ----------------------------------------------- ajouter
    Dim o As Object
    Application.ScreenUpdating = False
    ' ----------------------------------------------- ajouter
    Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row).Clear
    For Each Cel In Range("E2:E" & Cells(Application.Rows.Count, 5).End(xlUp).Row)
        If UBound(Split(Cel.Value, ",")) > 0 Then
            For i = 0 To UBound(Split(Cel.Value, ","))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ",")(i))
            Next i
        Else
            For i = 0 To UBound(Split(Cel.Value, ";"))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ";")(i))
            Next i
        End If
    Next Cel
    ' ----------------------------------------------- ajouter
    With Range("a:a")
        .RemoveDuplicates Columns:=1, Header:=xlYes
        .Sort Range("a1"), xlAscending, Header:=xlYes
    End With
    For Each o In Worksheets(Array("BdD Acteurs", "Filmographie", "Récompenses", "Biographie"))
        Sheets("Données").Columns(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Copy Destination:=o.Range("a1")
    Next
    Application.ScreenUpdating = True
End Sub

A bientôt :)
 
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Re,

Je te remercie beaucoup, je vais essayer de me dépatouiller parce que je me suis planter dans la feuille "BdD Acteurs" il était en colonne "B".
Je te remercie et te souhaite un très bon WE
 
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Bonjour,

Après avoir essayé de me dépatouiller je n'arrive pas à mettre dans la feuille "BdD Acteurs" il était en colonne "B".

Si quelqu'un passe par là et peut m'aider?
je vous remercie d'avance
 
Vote positif 0 Vote négatif
DoubleZero

DoubleZero

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Bonjour, maval, le Forum,

Version 4 :

Code: 
Sub Séparer_v4()
    Dim Cel As Range
    Dim DEST As Range
    ' ----------------------------------------------- ajouter
    Dim o As Object
    Application.ScreenUpdating = False
    ' ----------------------------------------------- ajouter
    Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row).Clear
    For Each Cel In Range("E2:E" & Cells(Application.Rows.Count, 5).End(xlUp).Row)
        If UBound(Split(Cel.Value, ",")) > 0 Then
            For i = 0 To UBound(Split(Cel.Value, ","))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ",")(i))
            Next i
        Else
            For i = 0 To UBound(Split(Cel.Value, ";"))
                Set DEST = IIf(Range("A2") = "", Range("A2"), Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                DEST.Value = Trim(Split(Cel.Value, ";")(i))
            Next i
        End If
    Next Cel
    ' ----------------------------------------------- ajouter
    With Range("a:a")
        .RemoveDuplicates Columns:=1, Header:=xlYes
        .Sort Range("a1"), xlAscending, Header:=xlYes
    End With
    For Each o In Worksheets(Array("Filmographie", "Récompenses", "Biographie"))
        Sheets("Données").Columns(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Copy Destination:=o.Range("a1")
    Next
    Sheets("Données").Columns(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Copy Destination:=Sheets("BdD Acteurs").Range("b1")
    Application.ScreenUpdating = True
End Sub

A bientôt :)
 
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
Re : Ajouter sur quatre feuilles

Bonjour,

Suite au code de DoubleZero que je remercie encore j'ai un petit souci au niveau du rangement qui se fait par ordre alpha dans chaque feuille mais les autres colonne ne suive pas il me décale toute les colonnes.
Si quelqu'un passe par là je le remercie d'avance, je joint mon fichier avec les explications.

Bonne journée.
 

Pièces jointes

  • ajouter-automatiquement-dans-plusieurs-feuilles.xlsm
    50.7 KB · Affichages: 59
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
Microsoft 365 Requête ADODB sur une colonne
Réponses
7
Affichages
239
fanch55
fanch55
J
  • Question
Microsoft 365 Recherchev sur plusieurs feuilles
Réponses
5
Affichages
186
nat54
nat54
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Automatisation de la création de feuilles en fonction des données de la cellule U13 et une feuille type
Réponses
7
Affichages
336
chaelie2015
chaelie2015
B
  • Question
XL 2019 formule
Réponses
6
Affichages
453
JHA
J
A
  • Question
Autres Remplir des feuilles a partir d'une autre feuille du même classeur
Réponses
4
Affichages
637
abdallah12
A
jgav
  • Résolu(e)
XL 2016 Incrémenter des formules dans une feuille, en la copiant et la renommant en même temps
Réponses
9
Affichages
256
jgav
jgav
P
  • Question
XL 2019 Mise en forme conditionnelle sur plusieurs feuilles
Réponses
6
Affichages
380
JHA
J
C
  • Résolu(e)
XL 2021 Aléa entre borne et ne pas prendre en compte cellule vide
Réponses
11
Affichages
574
candido57
C
F
  • Question
Microsoft 365 liste validation des données qui se réduit après sélection
Réponses
6
Affichages
435
fabchaninarom
F
M
  • Question
XL 2021 Problème d'une formule qui ne fonctionne pas
2
Réponses
21
Affichages
758
marco22
M

Membres actuellement en ligne

16 membres et 235 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 595
Messages
2 090 103
Membres
104 378
dernier inscrit
neovo