Copier coller des cellules sur plusieurs Onglets

[XXXL]

Bonjour a tous,

je dois recopier une liste de produits sur plusieurs feuilles en une seule et même liste sur une colonne et sur une feuille, je suis sur qu'avec une maccro adaptée on pourrait automatiser cela mais malgré mes recherches je n'ai pas trouvé ce qui convenait.

En pj il y a un exemple de mon fichier: en fait je voudrais recopier tous les CIP sur les différentes feuilles sur la première (Récap). Le problème c'est que le nombre de feuilles du fichier varie ainsi que les lignes ou sont positionnées l'intitulé des colonnes et leur ordonnancement. Je pense qu'il faudrait faire une macro qui recherche sur tous les onglets (sauf le premier) le mot "CIP" puis copier coller toute la colonne sous le CIP en enlevant les blancs (il peut y avoir des cellules au dessus de CIP qui ne sont pas à recopier et des cellules vides dans la liste).

Ceci étant mon premier message je ne sais pas si j'ai été assez clair, si vous avez besoin d'autres informations n'hésitez pas.

Merci d'avance.

 

[VDAVID]

Re : Copier coller des cellules sur plusieurs Onglets

Bonjour XXXL,

Tu peux essayer ce code, à copier coller dans un module de ton fichier:
(Alt+F11) ==> Insertion ==> Module

Sub Copie_colle()
    
    Dim i As Integer, k As Integer
    Dim c As Range
    Dim Ws As Worksheet
    Dim Intitulé As String, Col As String
    
    Application.ScreenUpdating = False
    
    'Feuille de destination
    Set Ws = Sheets("Récap")
    'Intitulé sur lequel effectuer la recherche
    Intitulé = "CIP"
    'Colonne de la feuille de destination où la copie des données se fait
    Col = "A"
    
        For i = 1 To Sheets.Count
            
            If Sheets(i).Name <> Ws.Name Then
                
                With Sheets(i).Cells
                    
                    Set c = .Find(Intitulé, , xlValues, xlWhole)
                    
                    If Not c Is Nothing Then
                        
                        For k = c.Row + 1 To .Cells(65536, c.Column).End(xlUp).Row
                            
                            If .Cells(k, c.Column).Value <> "" Then
                                
                                Ws.Range(Col & Ws.Range(Col & "65536").End(xlUp).Row + 1).Value = .Cells(k, c.Column).Value
                                
                            End If
                            
                        Next k
                        
                    End If
                    
                End With
                
            End If
            
        Next i
    Application.ScreenUpdating = True
        
End Sub

N'hésite pas si tu as des questions
Bonne journée !

 

[Staple1600]

Re : Copier coller des cellules sur plusieurs Onglets

Bonjour à tous

Un code VBA, brut de décoffrage, tout juste sorti du four
(il y a surement plus simple )

Sub MacroRecap()
Dim ws As Worksheet, Rcip As Range, Plg As Range, derlig As Long, ltr$
For Each ws In Worksheets
If Not ws.Name Like "Récap" Then
With ws
.Activate
On Error Resume Next
Set Rcip = .Cells.Find(What:="CIP", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
        derlig = .Cells(Application.Rows.Count, Rcip.Column).End(xlUp).Row
        ltr = Split(Rcip.Offset(1).Address(1, 0), "$")(0)
        Set Plg = Range(Rcip.Offset(1).Address & ":" & ltr & derlig)
        Plg.Copy Sheets("Récap").Cells(Application.Rows.Count, 1).End(xlUp)(2)
        End With
        Set Rcip = Nothing
        Set Plg = Nothing
End If
Next ws
End Sub

 

[XXXL]

Re : Copier coller des cellules sur plusieurs Onglets

....
J'ai presque honte d'avoir passé 2 heures a tout recopier a la mano alors qu'en 20 minutes vous avez trouvé le code. Vdavid ta macro marche impec ca m'a ressortit tous les résultats, parcontre je n'ai que des résultats partiels avec ta macro Staple, je ne suis pas assez bon pour savoir d'ou ça vient. D'ailleurs si vous avez des bouquins ou des conseils qui pourraient m'aider à comprendre ce langage assez énigmatique... En tout cas merci a tous les 2 pour votre rapidité.

 

[XXXL]

Re : Copier coller des cellules sur plusieurs Onglets

Bonjour tlm,

après plusieurs utilisations de la macro (qui fonctionnet très bien), j'ai vu qu'il y avait également des doublons dans ma liste du coup je cherche à intégrer la suppression des doublons dans ma macro en me basant sur un code trouvé sur le forum.
Voila ce que ça donne (pour l'instant ca ne fonctionne pas, j'essaie d'ajuster mais je rame un peu):

Sub Copie_colle()
    
    Dim i As Integer, k As Integer
    Dim c As Range
    Dim Ws As Worksheet
    Dim Intitulé As String, Col As String
    
    Application.ScreenUpdating = False
    
    'Feuille de destination
    Set Ws = Sheets("Récap")
    'Intitulé sur lequel effectuer la recherche
    Intitulé = "CIP*"
    'Colonne de la feuille de destination où la copie des données se fait
    Col = "A"
    
        For i = 1 To Sheets.Count
            
            If Sheets(i).Name <> Ws.Name Then
                
                With Sheets(i).Cells
                    
                    Set c = .Find(Intitulé, , xlValues, xlWhole)
                    
                    If Not c Is Nothing Then
                        
                        For k = c.Row + 1 To .Cells(65536, c.Column).End(xlUp).Row
                            
                            If .Cells(k, c.Column).Value <> "" Then
                                
                                Ws.Range(Col & Ws.Range(Col & "65536").End(xlUp).Row + 1).Value = .Cells(k, c.Column).Value
                                
                            End If
                            
                        Next k
                        
                    End If
                    
                End With
                
            End If
            
        Next i
        Doublon = Range("A65000").End(xlUp).Value
If Application.CountIf(Range("A2:A" & Range("A65000").End(xlUp).Row), Doublon) > 1 Then
Range("A65000").End(xlUp).EntireRow.ClearContents
End If
        Application.ScreenUpdating = True

End Sub