Macro compliqué pour moi

[meldja]

Bonjour,
Je dois traité une demande compliquée pour un collègue qui essaye de réparer une base de données xml.
Tout d'abord, il voulait insérer un certain nombre de colonnes en fonction de la valeur d'une cellule.
C'est fait grâce à l'aide qu'on m'a apporté ici. Après il voulait que je recopie la ligne en dessous des lignes vides, sur les lignes vides. C'est fait.
Maintenant, il me dit qu'il faut supprimer des cellules. Et la c'est un peu complexe pour moi.
Le fichier original de 40000 lignes se compose de blocs différents en nombre de colonnes et de lignes, d’où la complexité de la demande.
Ils commencent tous à partir de la colonne "AU" (ça s'est positif)
Dans l'exemple sur le fichier joint, les 13 premiers blocs se composent de 11 colonnes chacun et de 13 lignes (autant de lignes que de blocs)
Les 3 blocs suivants se composent de 10 colonnes chacun et de 3 lignes.
Je dois supprimer les lignes que je n'ai pas colorées pour chaque bloc qui commence à partir de la colonne "AU".
Pour l'instant, j'ai réussi à les supprimer mais il faut relancer la macro des centaines de fois parce que je me sers de la cellule active pour identifier les blocs.
Il faut donc que je clique dans une cellule de la colonne "AV" où se trouvent des occurrences pour identifier les blocs.
Et là je bloque, j'ai déjà passé 2 jours pour faire le fichier en pièce jointe. Si quelqu'un ou quelqu'une peut me donner un coup de main, ça m'aiderait bien.
Merci et bonne journée

 

[Bebere]

bonjour
code à mettre dans un module

Option Explicit
Dim ws As Worksheet, l As Long, c As Long, d As Long, f As Long

Public Sub SupprimeCel()    'meldja
    Application.ScreenUpdating = False
    Worksheets("new 1").Activate
    d = 47 'AU
    For l = 4 To 19 'lignes
        If Range("AV" & l) Like "*" & 24073 & "*" Or Range("AV" & l) Like "*" & 24074 & "*" Then
            For c = 47 To 189 'colonnes
                If Cells(l, c).Interior.ColorIndex = xlNone Then
               Cells(l, c) = ""
                End If
            Next c
        End If
Next l

    For l = 4 To 19
        f = Cells(l, 16384).End(xlToLeft).Column
            For c = f To d Step -1
                If Cells(l, c) = "" Then
                Cells(l, c).Delete shift:=xlToLeft
                End If
            Next c
    Next l
    Application.ScreenUpdating = True
End Sub

code simplifié

Public Sub SupprimeCel()    'meldja
    Application.ScreenUpdating = False
    Worksheets("new 1").Activate
    d = 47    'AU
    For l = 4 To 19
        f = Cells(l, 16384).End(xlToLeft).Column
        If Range("AV" & l) Like "*" & 24073 & "*" Or Range("AV" & l) Like "*" & 24074 & "*" Then
            For c = f To d Step -1
                If Cells(l, c).Interior.ColorIndex = xlNone Then
                    Cells(l, c).Delete shift:=xlToLeft
                End If
            Next c
        End If
    Next l
    Application.ScreenUpdating = True
End Sub

 

[meldja]

Bonjour
Merci pour ta réponse, mais ça ne m'aide pas vraiment. Les couleurs, je les ai mises pour expliquer ce que je veux. Sur le fichiers de plus de 40 000 lignes, il n'y en a pas donc Interior.ColorIndex = xlNone ne marchera pas.
En tout cas c'est gentil d'avoir répondu.
Bonne journée

 

[pierrejean]

Bonjour meldja
Salut Bebere

Un essai

 

[meldja]

Bonjour,
C'est pas la première fois que tu réponds à mes besoins. Encore merci et bonne journée.
C'est exactement ce que je recherchais. Je vais étudier ton code pour comprendre comment tu as fait.
Je mets le sujet "résolu". Merci