Résolu Macro compliqué pour moi

meldja

XLDnaute Impliqué
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
 

Fichiers joints

Bebere

XLDnaute Barbatruc
bonjour
code à mettre dans un module
VB:
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é
VB:
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
 
Dernière édition:

meldja

XLDnaute Impliqué
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
 

meldja

XLDnaute Impliqué
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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas