Autres Copier des lignes dans différents onglets en fonction de la valeur de différentes cellules

S

SPARKLETOF

XLDnaute Junior
Bonjour,

Je viens vers vous car je n’arrive pas à faire ce que je veux malgré mes recherches. .

Mon document Excel (que je joint), se compose comme suit :

un onglet « 2023 » regroupant mes données et de 5 onglets portant le nom d’une cellule donnée dans « 2023 ». Param1 (correspondant à la cellule E1 de « 2023 »), Param2
(correspondant à la cellule F1 de « 2023 »), etc…

J’aimerais que la ligne soit copiée si "OUI" est indiqué de la colonne Param1 dans l’onglet "Param1 », si "OUI" est indiqué dans la colonne Param2 dans l’onglet "Param1" et ainsi de suite pour les onglets définis.

De plus, j’aimerais que cela se produise lorsque l’on clique sur le bouton "Valider" que j’ai inséré dans l’onglet "2023".

Petite info, je suis à mon taff sur Excel 2007...........

Un grand merci par avance

Spark
 

Pièces jointes

  • Test enregistrement.zip
    159.5 KB · Affichages: 5
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Par pitié, formules toutes les demandes en même temps. Ca fait 3 fois que je rework pour rien.
En PJ, une dernière mouture avec :
VB: 
Sub RemplitPageCaract()
    Dim T1, T2, DL%
    Application.ScreenUpdating = False
    T1 = Sheets("caract1").Range("A3:D" & Sheets("caract1").[A65500].End(xlUp).Row)
    T2 = Sheets("caract2").Range("A3:D" & Sheets("caract2").[A65500].End(xlUp).Row)
    With Sheets("Caract")
        .[A3:D65000].ClearContents
        .Range("A3").Resize(UBound(T1, 1), UBound(T1, 2)) = T1
        DL1 = .[A65500].End(xlUp).Row
        For L = 3 To DL1
            .Cells(L, "C") = .Cells(L, "C") & " ( caract1 ) "
        Next L
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T2, 1), UBound(T2, 2)) = T2
        DL2 = .[A65500].End(xlUp).Row
        For L = DL1 + 1 To DL2
            .Cells(L, "C") = .Cells(L, "C") & " ( caract2 ) "
        Next L
    End With
End Sub
 

Pièces jointes

  • Test enregistrement (V4).zip
    152.4 KB · Affichages: 1
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
Ok, merci pour tout. Désolé d'être en fractionner mais les idées me viennent au fur et à mesure !
Comment cela se passe si je veux ajoute 1 onglet à regrouper avec les autres (par exemple, genre caract3) ?
Je vais tenter un truc car j'avoue ne pas tout comprendre dans la macro !!!
Merci encore.
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
SPARKLETOF à dit:
mais les idées me viennent au fur et à mesure
Cliquez pour agrandir...
Ce n'est jamais la bonne solution. En plus ça n'a jamais de fin.


Pour caract3 il suffit d'adapter à la colonne J :
VB: 
If Not Intersect(Target, Range("E4:I1000")) Is Nothing Then
Le reste est automatique.
Et adapter RemplitPageCaract :
Pour le transfert en array :
Code: 
T3 = Sheets("caract3").Range("A3:D" & Sheets("caract3").[A65500].End(xlUp).Row)
Pour l'écriture, rajouter :
Code: 
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T3, 1), UBound(T3, 2)) = T3
        DL3 = .[A65500].End(xlUp).Row
        For L = DL2 + 1 To DL3
            .Cells(L, "C") = .Cells(L, "C") & " ( caract3 ) "
        Next L
 
Dernière édition:
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
sylvanu à dit:
Bonjour,

Ce n'est jamais la bonne solution. En plus ça n'a jamais de fin.


Pour caract3 il suffit d'adapter à la colonne J :
VB: 
If Not Intersect(Target, Range("E4:I1000")) Is Nothing Then
Le reste est automatique.
Et adapter RemplitPageCaract :
Pour le transfert en array :
Code: 
T3 = Sheets("caract2").Range("A3:D" & Sheets("caract3").[A65500].End(xlUp).Row)
Pour l'écriture, rajouter :
Code: 
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T3, 1), UBound(T3, 2)) = T3
        DL3 = .[A65500].End(xlUp).Row
        For L = DL2 + 1 To DL3
            .Cells(L, "C") = .Cells(L, "C") & " ( caract3 ) "
        Next L
Cliquez pour agrandir...
Je te remercie pour tout ! Je vais regarder çà et me lancer !!!
Bonne journée
 
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
Hello,

j'ai fais quelques modifs mais j'ai un soucis pour le dernier point :

VB: 
Sub RemplitPageResidus()
    Dim T1, T2, T3, T4, DL%
    Application.ScreenUpdating = False
    T1 = Sheets("Residus FS").Range("A3:D" & Sheets("Residus FS").[A65500].End(xlUp).Row)
    T2 = Sheets("Residus 105").Range("A3:D" & Sheets("Residus 105").[A65500].End(xlUp).Row)
    T3 = Sheets("Residus 180").Range("A3:D" & Sheets("Residus 180").[A65500].End(xlUp).Row)
    T4 = Sheets("Residus 260").Range("A3:D" & Sheets("Residus 260").[A65500].End(xlUp).Row)
    With Sheets("Residus")
        .[A3:D65000].ClearContents
        .Range("A3").Resize(UBound(T1, 1), UBound(T1, 2)) = T1
        DL1 = .[A65500].End(xlUp).Row
        For L = 3 To DL1
            .Cells(L, "C") = "Residus FS" & " - " & .Cells(L, "C")
        Next L
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T2, 1), UBound(T2, 2)) = T2
        DL2 = .[A65500].End(xlUp).Row
        For L = DL1 + 1 To DL2
            .Cells(L, "C") = "Residus 105" & " - " & .Cells(L, "C")
        Next L
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T3, 1), UBound(T3, 2)) = T3
        DL3 = .[A65500].End(xlUp).Row
        For L = DL2 + 1 To DL3
            .Cells(L, "C") = "Residus 180" & " - " & .Cells(L, "C")
        Next L
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T4, 1), UBound(T4, 2)) = T4
        DL3 = .[A65500].End(xlUp).Row
        For L = DL3 + 1 To DL4
            .Cells(L, "C") = "Residus 260" & " - " & .Cells(L, "C")
        Next L
    End With
End Sub
Pour le "residus 260" n'apparait pas... je n'arrive pas à comprendre pourquoi !
 

Pièces jointes

  • Test enregistrements.zip
    278.2 KB · Affichages: 0
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
Bonjour à tous,
je reviens vers vous car j'ai voulu faire une modif sur le fichier mais cela ne fonctionne pas.
J'ai 2 onglets "Couleur visuelle" et "Couleur filtree". Les valeurs doivent être ramenées dans l'onglet "Couleur"...
J'ai recopié "bêtement" la macro qui me permettait de regrouper les valeurs des résidus mais là ça ne fonction pas !!

VB: 
Sub RemplitPageCouleur()
    Dim C1, C2, CL%
    Application.ScreenUpdating = False
    C1 = Sheets("Couleur filtree").Range("A3:D" & Sheets("Couleur filtree").[A65500].End(xlUp).Row)
    C2 = Sheets("Couleur visuelle").Range("A3:D" & Sheets("Couleur visuelle").[A65500].End(xlUp).Row)
          With Sheets("Couleur")
        .[A3:D65000].ClearContents
        .Range("A3").Resize(UBound(C1, 1), UBound(C1, 2)) = C1
        CL1 = .[A65500].End(xlUp).Row
        For L = 3 To CL1
            .Cells(L, "C") = "Couleur filtree" & " - " & .Cells(L, "C")
        Next L
        
        CL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & CL).Resize(UBound(C2, 1), UBound(C2, 2)) = C2
        CL2 = .[A65500].End(xlUp).Row
        For L = CL1 + 1 To CL2
            .Cells(L, "C") = "Couleur visuelle" & " - " & .Cells(L, "C")
        Next L
          End With
End Sub

Le code que j'ai copié et qui fonctionne est celui-là :

Code: 
Sub RemplitPageResidus()
    Dim T1, T2, T3, T4, DL%
    Application.ScreenUpdating = False
    T1 = Sheets("Residus FS").Range("A3:D" & Sheets("Residus FS").[A65500].End(xlUp).Row)
    T2 = Sheets("Residus 105").Range("A3:D" & Sheets("Residus 105").[A65500].End(xlUp).Row)
    T3 = Sheets("Residus 180").Range("A3:D" & Sheets("Residus 180").[A65500].End(xlUp).Row)
    T4 = Sheets("Residus 260").Range("A3:D" & Sheets("Residus 260").[A65500].End(xlUp).Row)
    With Sheets("Residus")
        .[A3:D65000].ClearContents
        .Range("A3").Resize(UBound(T1, 1), UBound(T1, 2)) = T1
        DL1 = .[A65500].End(xlUp).Row
        For L = 3 To DL1
            .Cells(L, "C") = "Residus FS" & " - " & .Cells(L, "C")
        Next L
        
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T2, 1), UBound(T2, 2)) = T2
        DL2 = .[A65500].End(xlUp).Row
        For L = DL1 + 1 To DL2
            .Cells(L, "C") = "Residus 105" & " - " & .Cells(L, "C")
        Next L
        
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T3, 1), UBound(T3, 2)) = T3
        DL3 = .[A65500].End(xlUp).Row
        For L = DL2 + 1 To DL3
            .Cells(L, "C") = "Residus 180" & " - " & .Cells(L, "C")
        Next L
        
        DL = 1 + .[A65500].End(xlUp).Row
        .Range("A" & DL).Resize(UBound(T4, 1), UBound(T4, 2)) = T4
        DL4 = .[A65500].End(xlUp).Row
        For L = DL3 + 1 To DL4
            .Cells(L, "C") = "Residus 260" & " - " & .Cells(L, "C")
        Next L
    End With
End Sub

SI une âme charitable pouvait m'aider...
Merci par avance.
Spark
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Je m'étonne de cette ligne de code :
VB: 
.Cells(L, "C") = "Couleur filtree" & " - " & .Cells(L, "C")
cela revient à faire :
Sheets("Couleur").Cells(L, "C") = "Couleur filtree" & " - " & Sheets("Couleur").Cells(L, "C")
Ne serait pas plutôt :
Code: 
.Cells(L, "C") = "Couleur filtree" & " - " & C1.Cells(L, "C")
et
.Cells(L, "C") = "Couleur filtree" & " - " & C2.Cells(L, "C")
Pour que les valeurs des bonnes feuilles soient copiées ?
 
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
sylvanu à dit:
Bonjour,
Je m'étonne de cette ligne de code :
VB: 
.Cells(L, "C") = "Couleur filtree" & " - " & .Cells(L, "C")
cela revient à faire :
Sheets("Couleur").Cells(L, "C") = "Couleur filtree" & " - " & Sheets("Couleur").Cells(L, "C")
Ne serait pas plutôt :
Code: 
.Cells(L, "C") = "Couleur filtree" & " - " & C1.Cells(L, "C")
et
.Cells(L, "C") = "Couleur filtree" & " - " & C2.Cells(L, "C")
Pour que les valeurs des bonnes feuilles soient copiées ?
Cliquez pour agrandir...
Bonjour,

Merci de votre retour !!

je t'avoue que j'ai du mal à comprendre....Cela n'aurait pas dû fonctionné en copiant l'autre code tout en changeant les noms ?
Du coup, les 2 lignes il faut qu'elles remplacent lesquelles au juste car dans votre proposition cela revient à tout regrouper dans l'onglet "Couleur filtree", non ?
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
SPARKLETOF à dit:
cela revient à tout regrouper dans l'onglet "Couleur filtree", non ?
Cliquez pour agrandir...
Non, la feuille utilisée est celle définie par With, en l'occurrence Sheets("Couleur") et non Sheets("Couleur filtrée")
Soit vous mettez .Cells(... et cela réfère à la feuille déclarée dans le With, ou vous mettez C1.Cells(... et cela réfère à la feuille déclarée dans C1.
 
Vote positif 0 Vote négatif
S

SPARKLETOF

XLDnaute Junior
J'ai du mal.....
Je ne sais même plus où corriger !
J'ai fait cette modif mais ca ne marche pas...
VB: 
 Sub RemplitPageCouleur()
Dim C1, C2, CL%
Application.ScreenUpdating = False
C1 = Sheets("Couleur filtree").Range("A3:D" & Sheets("Couleur filtree").[A65500].End(xlUp).Row)
C2 = Sheets("Couleur visuelle").Range("A3:D" & Sheets("Couleur visuelle").[A65500].End(xlUp).Row)
With Sheets("Couleur")
.[A3:D65000].ClearContents
.Range("A3").Resize(UBound(C1, 1), UBound(C1, 2)) = C1
CL1 = .[A65500].End(xlUp).Row
For L = 3 To CL1
.Cells(L, "C") = "Couleur filtree" & " - " & C1.Cells(L, "C")
Next L
      
CL = 1 + .[A65500].End(xlUp).Row
.Range("A" & CL).Resize(UBound(C2, 1), UBound(C2, 2)) = C2
CL2 = .[A65500].End(xlUp).Row
For L = CL1 + 1 To CL2
.Cells(L, "C") = "Couleur visuelle" & " - " & C2.Cells(L, "C")
Next L
End With
End Sub
Désolé :(
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
:rolleyes: A vouloir trop simplifier on finit par dire n'importe quoi.
C1 et C2 ne désignent pas des feuilles mais des plages, donc ce que j'ai dit n'est pas logique.
D'après ce que j'ai compris, Testez :
VB: 
Sub RemplitPageCouleur()
Dim C1, C2, CL%
Application.ScreenUpdating = False
C1 = Sheets("Couleur filtree").Range("A3:D" & Sheets("Couleur filtree").[A65500].End(xlUp).Row)
C2 = Sheets("Couleur visuelle").Range("A3:D" & Sheets("Couleur visuelle").[A65500].End(xlUp).Row)
With Sheets("Couleur")
    .[A3:D65000].ClearContents
    .Range("A3").Resize(UBound(C1, 1), UBound(C1, 2)) = C1
    CL1 = .[A65500].End(xlUp).Row
    For L = 3 To CL1
        .Cells(L, "C") = "Couleur filtree" & " - " & Sheets("Couleur filtree").Cells(L, "C")
    Next L
    CL = 1 + .[A65500].End(xlUp).Row
    .Range("A" & CL).Resize(UBound(C2, 1), UBound(C2, 2)) = C2
    CL2 = .[A65500].End(xlUp).Row
    For L = CL1 + 1 To CL2
        .Cells(L, "C") = "Couleur visuelle" & " - " & Sheets("Couleur visuelle").Cells(L, "C")
    Next L
End With
End Sub
Sinon adaptez suivant votre besoin, avec ces règles :
Si la feuille concernée est bien celle définie par le With, mettez .Cells(..., sinon précisez la feuille à cibler avec Sheets("NomFeuille").Cells(L, "C")
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
L'autre solution, si vous avez peur de vous mélanger les pinceaux, est de supprimer le With. C'est plus lourd mais évite les ambiguïtés en précisant à chaque fois la feuille utilisée :
VB: 
Sheets("Couleur").[A3:D65000].ClearContents
Sheets("Couleur").Range("A3").Resize(UBound(C1, 1), UBound(C1, 2)) = C1
CL1 = Sheets("Couleur").[A65500].End(xlUp).Row
For L = 3 To CL1
    Sheets("Couleur").Cells(L, "C") = "Couleur filtree" & " - " & Sheets("Couleur filtree").Cells(L, "C")
Next L
 
Vote positif 0 Vote négatif

Discussions similaires

oguruma
POWERQUERY :: Récupérer des paramètres à partir d'un fichier texte sur disque et le transformer en table de paramètres
Réponses
1
Affichages
569
oguruma
oguruma
Sellig
  • Question
XL 2019 Transférer la valeur d’une formule dans Visual basic
Réponses
8
Affichages
412
job75
job75
A
  • Résolu(e)
Microsoft 365 cumuler des valeurs de cellules dont l'emplacement peut varier dans des tableaux
Réponses
4
Affichages
497
auloin
A
A
  • Résolu(e)
Microsoft 365 Copier la même cellule de plusieurs onglets dans différentes colonnes
2
Réponses
23
Affichages
1 K
AlexiaC
A
X
  • Résolu(e)
XL 2016 Souci pour mettre un nombre dans une cellule en croisant colonne et ligne.
2
Réponses
16
Affichages
945
Xender
X
C
  • Question
Autres Apprentissage d'une langue : adapter la couleur des cellules en fonction du pourcentage d'évaluation
Réponses
2
Affichages
448
crocrocro
C
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
324
Phil69970
Phil69970
M
  • Question
XL 2019 Images dans plusieurs cellules à partir de plusieurs URL
2
Réponses
15
Affichages
803
patricktoulon
patricktoulon
F
  • Résolu(e)
Microsoft 365 copier coller des colonnes en fonction de la valeur d'une cellule
Réponses
8
Affichages
626
loloboc
L
K
  • Résolu(e)
XL 2013 recherche en fonction de la valeur et du rang sur une ligne
Réponses
5
Affichages
308
komarlehomard
K

Membres actuellement en ligne

4 membres et 42 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
315 098
Messages
2 116 189
Membres
112 679
dernier inscrit
Yupanki