Code VBA pour masquer des colonnes

Bonsoir à tous,

J'aimerais avoir votre aide s'il vous plaît.

J'ai plusieurs fichiers qui sont pareil,

De la ligne 21 à 31 il ' y a des cellules colorés.

J'aimerais un code VBA pour supprimer les colonnes ou il y a 3 et plus de 3 cellules qui ne sont pas coloré entre les lignes 21 à 31 de chaque colonne mais à partir de la colonnes B. je souhaite garder la colonne A et ceux, pour toutes les feuilles, des fichiers qui se trouvent dans le Dossier "IMPAIR".

Je vous mets quelques fichiers en copie et il faut savoir que les vrais fichiers sont énormes.

J'espère que mes explications ont été clair,

Donc si vous avez un code VBA qui soit très très très rapide, je vous en remercie d'avance.

Bonjour,

Sub SuppColAllSheet()
For Each Sh In Worksheets
    MaxColonne = Sh.Cells(21, Columns.Count).End(xlToLeft).Column
    For Colonne = MaxColonne To 2 Step -1
        Couleur = 0
        For Ligne = 31 To 21 Step -1
            If Sh.Cells(Ligne, Colonne).Interior.Pattern = xlNone Then Couleur = Couleur + 1
        Next Ligne
        If Couleur >= 3 Then Sh.Columns(Colonne).Delete
    Next Colonne
Next Sh
End Sub

On parcours toutes les feuilles, en cherchant la derniere colonne rempli de la ligne 21.
Pour chaque colonnes de la derniere a la deuxieme (colonne B) on réinitialise la variable Couleur
Pour chaque ligne entre 21 et 31 si il n'y a pas de remplissage on ajoute +1 a la variable Couleur
Si la variable couleur est supérieur ou égal a 3, on supprime la colonne en cours.

et ceux, pour toutes les feuilles, des fichiers qui se trouvent dans le Dossier "IMPAIR"

Pas compris cette partie, ni pourquoi avoir envoyé trois fois le meme fichier

A+

Bonjour

la suppression des colonnes doivent t'elles laisser les données présentes sur les lignes 1 à 6 ou la suppression des colonnes est t'elle entière?

pour tous les fichiers qui se trouvent dans le dossier "impair" : par fichiers tu entends classeurs excel *.XLSX?

Sub SupprimerColonnesTousClasseurs()
Dim wb As Workbook
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

fDialog.Title = "Select a folder"
fDialog.InitialFileName = "C:\"
If fDialog.Show = -1 Then
   Debug.Print fDialog.SelectedItems(1)
End If
Dim oFso As Scripting.FileSystemObject
Dim fldr As Folder
Dim oFiles As Files, oFile As File
Set oFso = CreateObject("Scripting.FileSystemObject")
Set fldr = oFso.GetFolder(fDialog.SelectedItems(1))
Set oFiles = fldr.Files
For Each oFile In oFiles
  If LCase(oFso.GetExtensionName(oFile.Path)) = "xlsx" Then
    Set wb = Workbooks.Open(Filename:=fldr.Path & "\" & oFile.Name, ReadOnly:=False)
    SupprimerColonnesToutesFeuilles
    wb.Close SaveChanges:=True
    Set wb = Nothing
  End If

Next
End Sub

Sub SupprimerColonnesToutesFeuilles()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
  Call SupprimerColonnesFeuille(ws.Name)
Next
End Sub

Sub SupprimerColonnesFeuille(nomFeuille As String)
Dim lig As Long
Dim col As Long
Dim maxCol As Long
Dim countIndexNone As Long
Dim ws  As Worksheet
Set ws = ThisWorkbook.Sheets(nomFeuille)
  maxCol = ws.Cells(21, ws.Columns.Count).End(xlToLeft).Column
  For col = maxCol To 2 Step -1

   countIndexNone = 0
   For lig = 21 To 31

   If Cells(lig, col).Interior.ColorIndex = xlColorIndexNone Then
      countIndexNone = countIndexNone + 1
   End If
  Next lig
  If countIndexNone >= 3 Then
    ws.Columns(col).Delete
  End If
Next col
End Sub

Bonjour,

pour gagner un petit peu de temps d'exécution je mettrais le test du nombre de cellule sans couleur dans la boucle des lignes : en effet si les trois premières cellules sont sans couleur alors pas besoin de continuer la boucle...

Sub SupprimerColonnesFeuille(nomFeuille As String)
    Dim lig As Long, col As Integer, maxCol As Integer, countNone As Integer, ws As Worksheet
    Set ws = ThisWorkbook.Sheets(nomFeuille)
    maxCol = ws.Cells(21, Columns.Count).End(xlToLeft).Column
    For col = maxCol To 2 Step -1
        countNone = 0
        For lig = 21 To 31
            If ws.Cells(lig, col).Interior.Color = xlNone Then countNone = countNone + 1
            If countNone = 3 Then ws.Columns(col).Delete: Exit For
        Next lig
    Next col
End Sub

Et je pense qu'il faut ajouté un "ws" devant le Cells du "If" car sinon cela test la cellule de la feuille active...

@ bientôt

LouReeD

Bonjour à tous,

Alors j'ai mis les 3 fichiers pareils pour qu'en essayant de créer une VBA vous pouvez l'essayer et voir si cela peut être rapide ou pas.

Je vous remercie pour votre aide, et est ce que se serait possible de rajouter dans les codes VBA la suppression des feuilles n'ayant plus de donnée à partir de la ligne B?. Je m'explique, si toutes les colonnes ont été supprimer car il y a pluss de 3 cellules non coloré, dans la feuille il ne restera que la colonne A. Il faudra supprimer cette feuille.

j'espère que j'ai été claire dans mon explication,

Merci à tous pour votre aide 🤗

Bonjour scraper, la suppression des colonnes est entière, comme si elle n'existait plus

Bonsoir,

un test :

Sub SupprimerColonnesFeuille(nomFeuille As String)
    Dim lig As Long, col As Integer, maxCol As Integer, countNone As Integer, ws As Worksheet
    Set ws = ThisWorkbook.Sheets(nomFeuille)
    maxCol = ws.Cells(21, Columns.Count).End(xlToLeft).Column
    For col = maxCol To 2 Step -1
        countNone = 0
        For lig = 21 To 31
            If ws.Cells(lig, col).Interior.Color = xlNone Then countNone = countNone + 1
            If countNone = 3 Then ws.Columns(col).Delete: Exit For
        Next lig
        If ws.UsedRange.Count = 1 Then
            Application.DisplayAlerts = False
                ws.Delete
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next col
End Sub

On boucle pour supprimer les colonnes, une fois qu'on supprime une colonne on teste la zone de plage utilisée par la feuille, si cette zone est égale à 1 c'est qu'il n'y a plus de donnée sur la feuille, on la supprime en arrêtant les messages d'alertes, et on sort de la Sub car il n'y a plus de feuille.

@ bientôt

LouReeD

Merci LouReeD

Merci @ vous pour le retour.

Bonne continuation dans votre projet !

@ bientôt

LouReeD