Copier/coller des données de plusieurs feuilles sur une seule (VBA)

Le 26/07/2020 à 13:19

Bonjour,

Après une journée de recherche à tester 36 000 solutions sans parvenir au résultat souhaité, je m'en remet à vous ;

Je vous joins un fichier Excel sur lequel se trouvent plusieurs feuilles susceptible de contenir une donnée similaire (nom client). Mon but étant que lorsque je souhaite supprimer un client, grâce à un code VBA je puisse rechercher dans tous les onglets s'il contiennent une ligne de ce client. Si oui, je souhaite que la ligne de titre et la ligne client de chaque onglet se copie/colle sur la feuille "Suppression".

J'ai réussi dans un premier temps a reporter sur cette feuille, les uns après les autres, le nom des différents onglets répondant à ma condition. Cependant, dès que j'ajoute dans mon code la ligne venant copier/coller les lignes de titres ça beug :

  • seule la ligne de titre de "Général" est reportée avec la mise en forme et les valeur
  • ensuite la ligne de titre de "Contact" est reportée mais sans mise en forme
  • enfin, les ligne titre des autres onglets ne se reportent pas.

Je précise que pour chaque onglet le nombre de colonne peut varier ; la différenciation que j'ai faite concernant l'onglet "Général" par rapport aux autres s'explique par le fait que sur "Général" les 3 dernières colonnes de ma feuille sont composé par des Codes Postaux et villes qui sont des données que je ne souhaite pas reporter dans "suppression" et surtout qui venait fausser mon columns.count. Je me suis peut-être compliquée la vie, mais je n'ai pas trouvé d'autres solutions.

J'avais à la base prévu de créer un With pour chaque sheets (cf. module "Supprimer") mais avec le temps d'autres onglet seront créer et comporteront probablement une ligne client d'où l'utilisation dans "Module 1" de la solution "For each sWK..."

Dernière précision, comme 'l'onglet "Suppression" ne sera constituer que par les données d'un seul et même client à la fois, finalement je me fiche que la colonne "Client" reste nommée comme tel, c'est pour cela que je demande dans mon code que cette cellule soit remplacer par le nom du worksheet.

Bref, je vous mets mon code actuel et reste à votre écoute pour tout échange afin d'arriver à une solution. Je compte sur vous et vous serais tellement reconnaissante si vous m'aider à solutionner cela. 

Sub test()
Dim sWk As Worksheet
Dim rCel As Range
Dim I As Integer
Dim Nm As String
Dim Supp As Worksheet
Dim Lig As Long
Dim Lig2 As Long

Set Supp = Feuil7

Nm = InputBox("Client?")
Lig = 0
Lig2 = Lig + 1

Application.EnableEvents = False

For Each sWk In ThisWorkbook.Worksheets
If sWk.Name <> "Suppression" Then
iRow = sWk.Range("B" & Rows.Count).End(xlUp).Row
Select Case sWk.Name
Case "Général"
iCol = Range("Tableau1").Columns.Count
Case Else
iCol = Cells.SpecialCells(xlCellTypeLastCell).Column
End Select

Set rCel = sWk.Range("B4:B" & iRow).Find(Nm, LookIn:=xlValues, lookat:=xlWhole)

If Not rCel Is Nothing Then
sWk.Cells(4, 2).Resize(1, iCol).Copy Supp.Cells(Lig, 1)
Supp.Cells(Lig, 1) = sWk.Name
Supp.Cells(Lig2, 1) = "Test"
Lig = Lig + 3
Lig2 = Lig + 1

End If
End If
Next

Application.EnableEvents = True

End Sub
22classeur1-2-copie.zip (1.19 Mo)
Le 26/07/2020 à 18:25

Bonjour,

Un premier essai ... afin de savoir si j'ai bien compris le besoin ...

Le code n'est pas nécessairement optimisé ...

J'ai renommé les tableaux "Tableau1 à 6" ... afin d'utiliser une boucle.

Sub suppc()
Dim Nm As String
Dim Foundcell As Range
Dim sWk As Worksheet
Dim objShell As Object, objFolder As Object, oFolderItem As Object, Chemin As String
Dim Dl As Integer
Dim X As Byte

    Sheets("Suppression").Visible = True

    Nm = InputBox("Client ?")
    If Nm = "" Then Exit Sub
    Dl = Sheets("Suppression").Cells(Rows.Count, "A").End(xlUp).Row
    nct = Range("Tableau1").Columns.Count
    With Sheets("Suppression")
        .Range(.Cells(2, "A"), .Cells(Dl, nct)).ClearContents
    End With

    With Sheets("Général").Activate
        For X = 1 To 6
            Set Foundcell = Range("Tableau" & X).Find(Nm)
            If Not Foundcell Is Nothing Then
                Dl = Sheets("Suppression").Cells(Rows.Count, "A").End(xlUp).Row + 1
                Foundcell.Resize(1, nct).Copy Sheets("Suppression").Range("A" & Dl)
            End If
        Next X
    End With

    Sheets("Suppression").Activate
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, " ", &H1&)
    ActiveSheet.PageSetup.Orientation = xlLandscape
    ActiveSheet.PageSetup.Zoom = False
    ActiveSheet.PageSetup.RightMargin = Application.InchesToPoints(0.3)
    ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(0.3)

    On Error Resume Next
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    fName = Chemin & "\sauvegarde suivi " & Nm & ".pdf"

    ChDir Chemin
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    On Error GoTo 0
End Sub
22sarah-gsk-classeur1-2-copie.zip (1.15 Mo)

ric

Le 26/07/2020 à 19:08

Merci Ric pour ta réponse et ton effort,

Mais après lecture et test de ton code celui-ci ne boucle que sur ma première feuille "Général" et vient coller sur "Suppression" plusieurs lignes clients.

Le 26/07/2020 à 19:24

Bonjour,

Étrange ... car, ici, s'inscrivent dans la feuille "Suppression" que les lignes du client sélectionné dans l'InputBox"

Est-ce que tu as testé le fichier que j'ai joint ?

Ou est-ce que tu as collé le code dans ton fichier de travail ?

Je demande car, comme mentionné, j'ai renommé les tableaux.

Ou bien encore, je n'ai pas compris correctement ta demande ...

ric

Le 26/07/2020 à 19:42

Bonjour,

Je viens de comprendre que la recherche est la recherche d'une partie du mot et non une recherche du mot exacte.

Je m'excuse de ne pas avoir mieux testé la chose ...

ric

Le 26/07/2020 à 19:56

Bonjour,

Et en changeant : Set Foundcell = Range("Tableau" & X).Find(Nm)

Pour : Set Foundcell = Range("Tableau" & X).Find(what:=Nm, LookIn:=xlValues, LookAt:=xlWhole)

Afin d'avoir une recherche du terme exact ...

ric

Le 26/07/2020 à 22:26

Oh yeaaah ! On est pas loin.

Juste, du coup, il ne me copie pas les 1e ligne de chaque tableau et ne remplace pas le nom client par le titre du worksheet.

Le 26/07/2020 à 23:00

Bonjour,

Avec les deux dernières consignes ...

Un essai ...

Sub suppc()
Dim Nm As String
Dim Foundcell As Range
Dim sWk As Worksheet
Dim objShell As Object, objFolder As Object, oFolderItem As Object, Chemin As String
Dim Dl As Integer, Dc As Byte
Dim X As Byte

    Sheets("Suppression").Visible = True

    Nm = InputBox("Client ?")
    If Nm = "" Then Exit Sub
    Dl = Sheets("Suppression").Cells(Rows.Count, "A").End(xlUp).Row
    nct = Range("Tableau1").Columns.Count
    With Sheets("Suppression")
        .Range(.Cells(1, "A"), .Cells(Dl, nct)).Clear
    End With

    With Sheets("Général").Activate
        For X = 1 To 6
            Set Foundcell = Range("Tableau" & X).Find(what:=Nm, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Foundcell Is Nothing Then
                Dl = Sheets("Suppression").Cells(Rows.Count, "A").End(xlUp).Row + 2
                If Dl = 3 Then Dl = 1
                Dc = Range("Tableau" & X).Columns.Count
                Range("Tableau" & X).Rows(0).Copy Sheets("Suppression").Range("A" & Dl)
                Dl = Sheets("Suppression").Cells(Rows.Count, "A").End(xlUp).Row + 1
                Foundcell.Resize(1, nct).Copy Sheets("Suppression").Range("A" & Dl)
                Sheets("Suppression").Range("A" & Dl) = Range("Tableau" & X).Parent.Name
            End If
        Next X
    End With

    Sheets("Suppression").Activate
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, " ", &H1&)
    ActiveSheet.PageSetup.Orientation = xlLandscape
    ActiveSheet.PageSetup.Zoom = False
    ActiveSheet.PageSetup.RightMargin = Application.InchesToPoints(0.3)
    ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(0.3)

    On Error Resume Next
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    fName = Chemin & "\sauvegarde suivi " & Nm & ".pdf"

    ChDir Chemin
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    On Error GoTo 0
End Sub

ric

Le 27/07/2020 à 00:26

Holalala !!

Un énorme merci à toi Ric !!

On fait tous la holà pour lui

Le 27/07/2020 à 10:43

ric

Rechercher des sujets similaires à "copier coller donnees feuilles seule vba"