Besoin d'aide pour finir une macro VBA [Résolu]

[Poulette44]

Bonjour,

Je désire faire une macro dont le but est d'aller extraire certaines données d'une feuille pour les mettre dans une autre...mais j'ai vraiment besoin de faire dans la dentelle...

explications :

J'ai un doc de base en feuille 1 que nous appelerons "Export"
Dans cet export j'ai une colonne qui contient des informations cellule par cellule.
On peut dire que j'ai des blocs de ligne, chacun de ces blocs étant délimités par un titre sur fond gris.
Sous le titre sur fond gris, j'ai une cellule sur fond jaune "ACTIFS SUR 2" puis en dessous des cellules remplies de texte dont le nombre peut varier puis une autre cellule sur fond jaune "EXCLUSIFS CHANTEL.FR" puis des cellules de texte puis une dernière celllule sur fond jaune "EXCLUSIFS CHANTEL" avec en-dessous d'autres cellules avec texte...
Enfin de nouveau un titre sur fond gris etc...

Exemple :

TITRE
ACTIF SUR 2
MARQUE 1
MARQUE 2
MARQUE 3
MARQUE 4
MARQUE 5
EXCLUSIFS CHANTEL.FR
MARQUE 6
MARQUE 7
MARQUE 8
MARQUE 9
MARQUE 10
MARQUE 11
EXCLUSIFS CHANTEL
MARQUE 12
MARQUE 13
MARQUE 14
MARQUE 15
MARQUE 16
TITRE 2
ACTIF SUR 2
MARQUE 17
MARQUE 18
MARQUE 19
EXCLUSIFS CHANTEL.FR
MARQUE 20
MARQUE 21
MARQUE 22
MARQUE 23
EXCLUSIFS CHANTEL
MARQUE 24
MARQUE 25
MARQUE 26

Objectif :

Faire apparaître dans une nouvelle feuille toutes les "Marques" "ACTIFS SUR 2" en gardant le "TITRE" de chacunes.

Exemple de résultat :

TITRE
MARQUE 1
MARQUE 2
MARQUE 3
MARQUE 4
MARQUE 5
TITRE 2
MARQUE 17
MARQUE 18
MARQUE 19


Voici le programme VBA que j'ai commencé à écrire :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Dim I As Integer   'Numéro de ligne sur Export
Dim J As Integer   'Numéro de ligne sur Actifs2
 
 
'je supprime la feuille Actifs2 si elle existe déjà
    If Sheets(2).Name = "Actifs2" Then Sheets(2).Delete
 
'Inéserer une feuille en 2ème position
    Sheets.Add after:=Sheets(1)
    ActiveSheet.Name = "Actifs2"
 
'Trouvons la ligne de Actifs sur 2 : méthode Find
    I = Sheets("Export").Range("B4:B37").Find("ACTIF SUR 2").Row + 1
 
'Copier Coller le titre en gris
    Sheets("Export").Range("B4").Copy _
       Destination:=Sheets("Actifs2").Range("B1")
 
'Boucle pour faire du =
'
    J = 2
    Do Until Sheets("Export").Cells(I, 2) = "EXCLUSIFS CHANTEL.FR"
 
          Sheets("Actifs2").Cells(J, 2) = Sheets("Export").Cells(I, 2)
 
    I = I + 1  'incrémenter i
    J = J + 1  'incrémenter j
 
    Loop

Avec ce programme j'arrive à extraire sur une autre feuille uniquement ce résultat :

TITRE
MARQUE 1
MARQUE 2
MARQUE 3
MARQUE 4
MARQUE 5


Auriez-vous une idée pour que je puisse faire en sorte que ce programme s'applique à toute la colonne et ne s'arrete pas uniquement au premier bloc de ligne ??

Quelques idées que j'avais :
le tableau pouvant varier de taille, je comptais utliser un CurrentRegion au lieu de mon Range("B4:B37")
et je comptais peut-être utliser le fait que mes titres soient sur fond gris pour pouvoir les identifier plus facilement...
Enfin, j'ai cette idée mais je ne sais pas le faire

d'où mon HELPPPPPPP à vous, gentils développeurs

Merci d'avance à ceux qui voudront bien m'aider!!

[gFZT82]

Bonjour Poulette44,

Voici une solution qui prend en compte la couleur GRIS du remplissage de la cellule qui contient le TITRE.
Il te faut l’adapter en fonction des paramètres exacts de ce remplissage.
Tu peux les relever en utilisant l’enregistreur de macro.
Note bien que cette procédure ne fonctionne que si la structure des données est bien celle que tu as indiquée, à savoir alternance de TITRE, ACTIF puis EXCLUSIF.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Option Explicit
Sub extraction()
Dim ws1 As Worksheet 'Feuille "Actifs2"
Dim ws2 As Worksheet 'Feuille "Export"
Dim Ligne_ws1 As Long
Dim Ligne_ws2 As Long
Dim DerLig_ws2 As Long
Dim Trouve As Boolean, Remplissage As Boolean
 
    'je supprime la feuille Actifs2 si elle existe déjà
    If Sheets(2).Name = "Actifs2" Then Sheets(2).Delete
    'Inserer une feuille en 2ème position
    Sheets.Add after:=Sheets(1)
    ActiveSheet.Name = "Actifs2"
 
    Set ws1 = ThisWorkbook.Worksheets("Actifs2")
    Set ws2 = ThisWorkbook.Worksheets("Export")
    Ligne_ws1 = 1
    DerLig_ws2 = ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row
 
    For Ligne_ws2 = 1 To DerLig_ws2
        'Si le remplissage de la cellule en colonne B est gris (TITRE)
        With ws2.Cells(Ligne_ws2, 2).Interior
            If .Pattern = xlSolid And _
            .ThemeColor = xlThemeColorDark1 And _
            .TintAndShade = -4.99893185216834E-02 Then
                Remplissage = True
            Else
                Remplissage = False
            End If
        End With
        If Remplissage = True Then
            'J'écris "TITRE(x) dans la colonne B de la feuille "Actifs2"
            ws1.Cells(Ligne_ws1, 2) = ws2.Cells(Ligne_ws2, 2)
            Ligne_ws1 = Ligne_ws1 + 1
        End If
        If Left(ws2.Cells(Ligne_ws2, 2), 5) = "ACTIF" Then Trouve = True
        If Left(ws2.Cells(Ligne_ws2, 2), 5) = "EXCLU" Then Trouve = False
        If Trouve = True And Left(ws2.Cells(Ligne_ws2, 2), 5) <> "ACTIF" Then
            ws1.Cells(Ligne_ws1, 2) = ws2.Cells(Ligne_ws2, 2)
            Ligne_ws1 = Ligne_ws1 + 1
        End If
    Next Ligne_ws2
End Sub

Cordialement.

[Poulette44]

Magnifique!!
Vraiment merci beaucoup
Et merci pour la rapidité de ta réponse!!

Juste une dernière question
en copiant le titre sur la nouvelle feuille, est-ce possible de copier également le fond gris et la police en gras ?

[gFZT82]

Il suffit de remplacer cette partie

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
        If Remplissage = True Then
            'J'écris "TITRE(x) dans la colonne B de la feuille "Actifs2"
            ws1.Cells(Ligne_ws1, 2) = ws2.Cells(Ligne_ws2, 2)
            'Le remplissage de la cellule est gris (TITRE)
            With ws1.Cells(Ligne_ws1, 2).Interior
                .Pattern = xlSolid
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -4.99893185216834E-02
            End With
            'La police est en caractères gras
            ws1.Cells(Ligne_ws1, 2).Font.Bold = True
            Ligne_ws1 = Ligne_ws1 + 1
        End If

Bon courage pour la suite
Cordialement.

[Poulette44]

C'est Top!! Tout fonctionne parfaitement
Sincèrement Mille Mercis pour ton aide, je n'y serais jamais arrivée toute seule!