Copier des cellules en fonction de la valeur de la cellule adjacente

[ptirouX]

Bonjour,

Je cherche à réaliser dans un tableau une synthèse de cellules présentes sur plusieurs feuilles qui se créer en fonction d'une macro. Le nom de ces feuilles commence toujours par DSI (1,2,3,.....).

Si dans la colonne B de ces feuilles il est noté CT (pour Contrôle technique) alors il faut copier la description du contrôle qui est dans la cellule adjacente (par exemple C5 si CT se trouve en B5.) dans une autre feuille.

Comme je disais au début, les feuilles sont créées par l'utilisateur et sur chaque feuille il peut y avoir plusieurs Contrôles Techniques mais pas forcément les uns à la suite des autres.

Donc pour résumer, j'aimerais copier l'ensemble des CT présents sur les feuilles DSI1, DSI2,.... dans une autre feuille les uns en dessous des autres.

J'espère être clair car je m'y perds moi-même dans mes explications ^^ et malheureusement je ne peux pas mettre de fichier exemple.

Dans l'attente de vos réponses, bonne journée à tous!!!!

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Salut

j'avais bien une solution à te proposer,
en supposant que ta feuille de synthèse s'appelle "Synthèse"

Sub synthese()
'parcours de toutes les feuilles du classeur
For Each s In Worksheets
    'permet de tester le nom des feuilles et donc exclure la feuille de synthèse
    If s.Name Like "DSI*" Then
        'MsgBox s.Name

        nbele = s.Range("B65536").End(xlUp).Row
        'parcours de la colonne B de la feuille concernée
        For Each cellule In s.Range("B1:B" & nbele)
            If cellule = "CT" Then
                cellule.Copy Destination:=Sheets("Synthèse").Range("B65536").End(xlUp).Offset(1, 0)
                'c'est ici que ca bug... ?????
                cellule.Offset(0, 1).Copy Destination:=Sheets("Synthèse").Range("C65536").End(xlUp).Offset(1, 0)
            End If
        Next cellule
    End If
Next s
End Sub

mais pour une raison que je ne m'explique pas.. ca ne marche pas.. ca s'arrête à la première occurence de CT...

je te mets le code quand même en tant que piste.

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

bizarement. il semble que le copier coller fasse bugger le code
alors qu'avec un simple affichage dans un msgbox.. ca se passe bien

Sub synthese()

For Each s In Worksheets
    If s.Name Like "DSI*" Then
        MsgBox s.Name
        nbele = s.Range("B65536").End(xlUp).Row
        For Each cellule In s.Range("B1:B" & nbele)
            If cellule = "CT" Then
                MsgBox cellule & " " & cellule.Offset(0, 1)
                'cellule.Copy Destination:=Sheets("Synthèse").Range("B65536").End(xlUp).Offset(1, 0)
                'cellule.Offset(0, 1).Copy Destination:=Sheets("Synthèse").Range("C65536").End(xlUp).Offset(1, 0)
            End If
        Next cellule
    End If
Next s
End Sub

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

ha.. et ici. ca semble fonctionner..

Sub synthese()

For Each s In Worksheets
    If s.Name Like "DSI*" Then
        MsgBox s.Name
        nbele = s.Range("B65536").End(xlUp).Row
        For Each cellule In s.Range("B1:B" & nbele)
            If cellule = "CT" Then
                MsgBox cellule & " " & cellule.Offset(0, 1)
                Sheets("Synthèse").Activate
                cellule.Copy Destination:=ActiveSheet.Range("B65536").End(xlUp).Offset(1, 0)
                cellule.Offset(0, 1).Copy Destination:=ActiveSheet.Range("C65536").End(xlUp).Offset(1, 0)
            End If
        Next cellule
    End If
Next s
End Sub

donc voila. tu n'as plus qu'à adapter à ton fichier ;-)

et du coup. je te met le fichier exemple que j'ai utilisé

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Bonjour vgendron

Et surtout merci de tes réponses rapides et efficaces. c'est exactement ce qu'il me fallait. Merci encore.

Penses-tu qu'il est possible de rajouter par exemple dans la colonne A de la synthèse la provenance du CT, en gros ce qui apparait dans la msgbox DSI 1-CT-4?

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Re vgendron

Je reviens vers toi car j'essaye depuis ce matin d'adapter à mon fichier cependant j'ai quelques soucis.
1°/ sur ma premiere fiche DSI j'ai 5 CT en colonne or il s'arrête à 4 et m' affiche erreur 1004 erreur définie par l'application ou l'objet.
2°/ J'essaye de faire la copie sur ma fiche à un certains endroit ( le CT doit s'afficher à partir de B21 et la désignation du CT en C21 or là il me marque les CT à partir de B2 et les désignation à partir de D16.
3°/ lorsque je clique sur le bouton synthese, il m'affiche DSI 1 avec la message box et s'arrête là alors que lorsque je lance manuellement la macro depuis VB la macro va plus loin mais pas jusqu'au bout (cf. 1°/).
Cela fait 2 heure que j'essaye en vain ^^ si tu as une ébauche de solution.

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Hello

essaie avec ceci..

Sub synthese()

For Each s In Worksheets
    If s.Name Like "DSI*" Then
        'MsgBox s.Name
        nbele = s.Range("B65536").End(xlUp).Row
        For Each cellule In s.Range("D9:D" & nbele)
            If cellule = "CT" Then
                'copie le numéro de référence du DSI (J3-->colonne A)
                Sheets("Contrôle Technique").Range("A65536").End(xlUp).Offset(1, 0) = s.Range("J3")
                s.Range(cellule.Address, cellule.Offset(0, 4).Address).Copy Destination:=Sheets("Contrôle Technique").Range("A65536").End(xlUp).Offset(0, 1)
                'MsgBox cellule & " " & cellule.Offset(0, 1)
            End If
        Next cellule
    End If
Next s
End Sub

PS: j'ai défusionné les colonnes E F G H et ca fonctionne... mais pas re essayé avec les colonnes fusionnées

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Super tu es trop fort^^cela fonctionne même avec les cellules fusionnées j'adapte juste la trame de la feuille contrôle technique
En revanche je ne comprends pas le cheminement pour la copie de la référence du DSI en colonne A, cela m'affiche dans les cellule #REF!.

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

A tout hasard tu n'aurais pas une ligne de code pour dupliquer une feuille (PDG DSI) en fonction de la valeur d'une cellule (calculé avec Nb Val sur une plage) ???
Car j'ai fait quelque chose cependant cela m'ouvre des boite de dialogue ce qui peut produire des erreurs par la suite en fonction des personnes qui utiliserons le fichier

Sub dupliquer_feuilles_Pdg_DSI()

Dim i As Integer
Dim ongl As String, nomb As String
nomb = InputBox("Nombre de copie Pdg DSI1", "Nombre")
nomb = nomb - 1
ongl = InputBox("PdG DSI1", "PdG DSI")
For i = 1 To nomb
Sheets(ongl & i).Select
Sheets(ongl & i).Copy After:=Sheets(i + 2)
ActiveSheet.Name = ongl & i + 1
Next i
End Sub

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

En revanche je ne comprends pas le cheminement pour la copie de la référence du DSI en colonne A, cela m'affiche dans les cellule #REF!.

Je crois que dans ta feuille DSI, la cellule J3 contient une formule.. donc, si le résultat est #ref, la macro va copier #ref
justement, j'ai mis une valeur pour vérifier que ca copiait bien le contenu..

pour la copie des onglets

Sub dupliquer_feuilles_Pdg_DSI()

Dim i, nomb As Integer
Dim ongl As String
'demande le nombre de copies souhaitées
nomb = InputBox("Nombre de copies Pdg DSI1", "Nombre")

ongl = "DSI n°"
'pour éviter de créer un DSI n° déjà existant, on demande le numéro du dernier (le plus grand)
dernier = InputBox("donnez le numéro du dernier DSI")
'ongl = InputBox("PdG DSI1", "PdG DSI")
For i = 1 To nomb
    Sheets(ongl & i).Select
    Sheets(ongl & i).Copy After:=Sheets(i + 1)
    ActiveSheet.Name = ongl & i + dernier
Next i
End Sub

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

et hop. ce code ci se débrouille tout seul pour détecter le DSI max

Sub dupliquer_feuilles_Pdg_DSI()

Dim i, nomb, dernier As Integer

Dim ongl As String
nomb = InputBox("Nombre de copie Pdg DSI1", "Nombre")
dernier = 1
For Each ws In Worksheets()
    
    If ws.Name Like "DSI*" Then
        ici = InStr(ws.Name, "°")
        If CInt(Right(ws.Name, Len(ws.Name) - ici)) > dernier Then dernier = CInt(Right(ws.Name, Len(ws.Name) - ici))
    End If
Next ws


ongl = "DSI n°"
'dernier = InputBox("donnez le numéro du dernier DSI")
'ongl = InputBox("PdG DSI1", "PdG DSI")
For i = 1 To nomb
    Sheets(ongl & i).Select
    Sheets(ongl & i).Copy After:=Sheets(i + 1)
    ActiveSheet.Name = ongl & i + dernier
Next i
End Sub

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

le dernier avec la détection auto me met erreur erreur 13 incompatibilité de type mais sinon la 1ere version marche sa suffira merci bcp si je peux abusé j'aurais un dernier petit truc à demander

A l'intérieur de ma PDG DSI j'ai la référence de la DSI qui s'inscrit (DSI - 2015- 000 - 01)

Les 3 0 se complètent automatique via une feuille de renseignement cependant l'index de la fiche ( 01-02-...) non.

Donc la question a 1 million, est-il possible que la valeur de la cellule corespondent au chiffre du nom de l'ongle que l'on créer

Exemple, je duplique ma PDG DSI1 3 fois, sur la PDG DSI 2 s'inscrit dans la cellule référence 2015 - 000 - 02

Voir l'exemple

En tout un grand merci car je me noyais dans les demandes des conducteurs travaux et tu ma en levé un buisson d'épines du pied ^^

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

le dernier avec la détection auto me met erreur erreur 13 incompatibilité de type

Je pense que ca vient du fait que tu lances la macro avec onglet DSI qui n'a pas été renommé: par exemple un DSI n°1 (1)
donc.. renommer manuellement pour ne plus avoir le chiffre entre parenthèses. ou les supprimer avant de lancer la macro


pour le reste..
comme tu viens de renommer l'onglet crée, tu as le numéro , tu peux donc l'inscrire en Y20

ActiveSheet.Range("Y20") = i + CInt(dernier)

bon.. je sens qu'il va falloir jouer avec le fait que tu peux avoir plus de 10 DSI donc. plus de 10 PdG DSI..
et comme tu inscris le numéro sur deux cellules: (X20 pour les dizaines et Y20 pour les unités) il faut faire une petite opération
pour les numéros >9, faire une division par 10: récupérer la partie entière (dizaine) pour mettre en X20, et le reste (unité) en Y20

;-)

 

[ptirouX]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Super sa marche du tonnerre en fait je me suis pas embêter et j'ai directement fait une seule cellule pour le numéro sans le préfixe 0.

Je t'aurais bien remercier en te payant un ti coup à boire mais je sens que virtuellement sa va être compliqué à part si t dans le bordelais^^

Est ce que tu penses que je peux avec un seul bouton faire le duplication des DSI et des Page de garde DSI en même temps?

 

[vgendron]

Re : Copier des cellules en fonction de la valeur de la cellule adjacente

Sub dupliquer_feuilles_Pdg_DSI()

 Dim i, nomb As Integer
 Dim ongl As String
 'demande le nombre de copies souhaitées
 nomb = InputBox("Nombre de copies Pdg DSI1", "Nombre")

 'ongl = "DSI n°"
 'pour éviter de créer un DSI n° déjà existant, on demande le numéro du dernier (le plus grand)
 dernier = InputBox("donnez le numéro du dernier DSI")
 ongl = InputBox("PdG DSI1", "PdG DSI")
 For i = 1 To nomb
     Sheets(ongl & i).Select
     Sheets(ongl & i).Copy After:=Sheets(i)
     ActiveSheet.Name = ongl & i + dernier
     If (i + CInt(dernier)) > 9 Then
        dizaine = Int((i + CInt(dernier)) / 10)
        unité = (i + CInt(dernier)) Mod 10
    Else: unité = (i + CInt(dernier))
        dizaine = 0
    End If
     ActiveSheet.Range("X20") = dizaine
     ActiveSheet.Range("Y20") = unité
     
     
 Next i
 End Sub