Regrouper dans un onglet les données de plusieurs onglets

Bonjour à tous,

Je suis novice en VBA et essaie de produire une macro à partir d’un fichier composé de plusieurs onglets, chacun contenant un tableau.

J’aimerais regrouper dans un onglet "TEST", et sous commande, les données des autres onglets à condition que ces données soit sélectionnées via un « x » dans les colonnes AK :

• Si “x” est trouvé dans la colonne AK, copier au sein de la ligne associée les cellules des colonnes A à D et F à K

• Les coller dans l’onglet « TEST », à la dernière ligne du tableau et en commençant par la colonne B

• Dans la colonne A de « TEST » et pour chaque ligne copiée, copier le nom de l’onglet d’où ont été copiées les cellules

• Remplacer les « x » par des « ok »

1. Pour y aller progressivement j’ai d’abord essayé de copier la ligne entière contenant le « x » et je n’ai pas eu de problème :

Sub ESSAI()

Dim wsSGL As Worksheet, wsBPO As Worksheet, wsTest As Worksheet

Set wsSGL = ActiveWorkbook.Sheets("SGL")

Set wsBPO = ActiveWorkbook.Sheets("BPO")

Set wsTest = ActiveWorkbook.Sheets("Test")

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'Sheets("SGL").Activate

For Each ce In wsSGL.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

ce.Value = "ok"

End If

Next ce

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

ce.Value = "ok"

End If

Next ce

Application.ScreenUpdating = False

Application.Calculation = xlCalculationAutomatic

End Sub

2. En revanche je n’ai pas réussi, dans la colonne A de « TEST », et pour chaque ligne copiée, à copier le nom des onglets d’où ont été copiées les cellules… Voilà ce que j’ai essayé (ajout de la ligne en jaune pour l’onglet « BPO ») :

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

ce.Value = "ok"

wsTest.Range("A" & wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)).Value = "BPO"

End If

Next ce

3. Je n’ai pas non plus réussi à coller uniquement les cellules des colonnes A à D et F à K: avec mon code, les cellules sont bien copiées mais uniquement celles associées au 1^er « x » de la colonne. Les autres « x » ne sont pas collés, et je ne comprends pas pourquoi… :

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

Dim range1 As Range, range2 As Range, multiplerange As Range

Set range1 = Range("A" & ce.Row & ":D" & ce.Row)

Set range2 = Range("F" & ce.Row & ":K" & ce.Row)

Set multiplerange = Union(range1, range2)

multiplerange.Copy Destination:=Sheets("Test").Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

ce.Value = "ok"

End If

Next ce

Merci d’avance pour votre aide ! En espérant que mes explications aient été claires….

Bonne soirée à tous,

Pauline

Bonjour,

Voici un premier essai :

Sub ESSAI()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
for each ws in worksheets(array("SGL", "BPO"))
    CopierLignes ws.name
next ws
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Sub CopierLignes(NomWsSource$, optional NomWsDest$ = "Test", optional RefPlageSource$ = "A:D, F:K", _
                    optional Critere$ = "x", Optional ColCrit$ = "AK")
t = split(RefPlageSource, ", ")
with Sheets(NomWsSource)
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 5 to dl
        If .cells(i, ColCrit).Value = Critere Then
            nvl = Sheets(NomWsDest).Cells(Rows.Count, 1).End(xlUp).row + 1
            Sheets(NomWsDest).Cells(nvl, 1).Value = NomWsSource
            for j = lbound(t) to ubound(t)
                .range(t(j)).rows(i).Copy Sheets(NomWsDest).range(t(j)).rows(nvl).offset(, 1)
            next j
            .cells(i, ColCrit).Value = "ok"
        End If
    Next i
end with
end sub

Pour l'instant, on exécute le code de la même manière pour les 2 feuilles, où on ne copie pas la ligne mais les colonnes A:D et F:K à destination de la colonne B, la colonne A étant remplie par le nom de la feuille source.

Ce n'est pas testé donc le risque de bug est non nul. En cas de problème, merci d'indiquer la ligne et le message d'erreur.

Cdlt,

Bonjour 3GB,

Désolée pour cette réponse tardive....

Merci beaucoup, ça marche parfaitement bien ! Il n'y a aucun bug, et tout ce que je souhaitais copié l'a été.

Les noms des onglets sont également bien repris.

Je n'avais pas tout de suite réussi à la faire marcher , je n'avais pas compris qu'il fallait cliquer dans la procédure ESSAI pour lancer le tout (très très débutante...).

Du coup, je m'étais forcée à retravailler la macro que j'avais commencée (d'où la réponse tardive), et j'ai fini par obtenir ce que je souhaitais, mais le résultat est beaucoup plus long et moins efficace que votre macro.... Il me reste à la comprendre dans les détails, car j'ai compris dans les grandes lignes, mais quelques éléments m'échappent encore.

Encore merci !

Bonjour Pilone (ou Pauline ?),

Merci pour ce retour ! Je suis content que le code ait fonctionné du premier coup.

En effet, la première macro ESSAI exécute la seconde qui est une macro dépendant de paramètres ne pouvant s'exécuter seule...

Le principe, c'est de passer le plus d'éléments en variables intrinsèques à la seconde macro et de définir les arguments dans la première macro. Ici, les paramètres précédés d'Optional sont facultatifs car ils ont une valeur par défaut.

Sinon, pour le reste, si vous avez des questions précises, n'hésitez pas à me les poser .

Cdlt,