Supression plage colonnes vides en VBA

Version imprimable

26/02/2013, 11h09
motmot

Supression plage colonnes vides en VBA

bonjour à tous,

Je coince sur un petit problème de suppression de cellules dans des plages sous Excel en VBA.

j'ai une ligne complète de date (255 lignes) sur un fichier xls et en dessous des valeurs mais pas pour chaque date. Mon but est de supprimer ces cellules vides et la date associée pour ressérer toute mes données sur la gauche comme dans l'exemple ci-dessous:

initial:
01.02.2013! 02.02.201! 03.02.2013! 04.02.2013
________2!_________!_________4!___________

Final (à obtenir):
01.02.2013! 03.02.2013
________2!_________4
J'ai bien fait une boucle qui part de la colonne 255 et qui remonte à 1 pour supprimer la plage chaque fois que la valeur est vide en ligne 2 mais cela prend beaucoup trop de temps. en effet ces plages de 2 lignesse répète dans la feuille et je doit donc boucler sur chaque plage pour formater mes données.

Avez-vous des idées en utilisant par exemple SpecialCells(xlCellTypeBlanks) afin de supprimer les cellules vides mais aussi la cellule au-dessus de la vide.

J'espère que j'ai été relativement clair dans mon explication car c'est pas si simple à exprimer.Merci d'avance,

Cordialement

Motmot
26/02/2013, 11h32
Kimy_Ire

Hum... Je n'ai pas bien compris.
1) Tu as des dates sur ta ligne 1 (par exemple) avec des chiffres en dessous de celle-ci ou
2) As-tu des dates toutes les 2 lignes (par exemple) avec des chiffres en dessous ?

J'entend par là : veux-tu supprimer des colonnes entières ou des cellules 2 par 2 toutes les deux lignes ?
26/02/2013, 11h35
supierre

Bonjour,

J'aimerais te poser quelques questions avant de lm'attaquer à ton problème:

Est-ce que une suppression de la colonne entière est envisageable? (si données en dessous ou au dessus sa pourrait poser problème)

pourrais-tu mettre à disposition un fichier épuré pour bien voir ton problème?

Cordialement
26/02/2013, 13h44
motmot

1 pièce(s) jointe(s)

bonjour,

Merci de vos réponses! Pour répondre à vos intérogations, la suppression des colonnes entières n'est pas possibles. Les données vont par 2 lignes. Toutes les deux lignes, je dois donc supprimer la cellule vide de le seconde ligne + la cellule du dessous et cela chaque 2 lignes. Voir exemple en pièce jointe. J'ai bien essayé de boucler de la colonne 255 à 1 et supprimer mes deux cellules pour jeux de données mais quand je commence à avoir un nombre important de lignes, ça devient vite lourd et très long. Avez-vous une idée pour accélérer ce code? Je pensais à repérer les cellules vides et les supprimer mais comment faire pour aussi supprimer la cellule du dessus?

Merci pour votre aide,
Cordialement

Motmot
26/02/2013, 14h36
supierre

Bonjour,

j'ai trouvé une solution, je suis en train de l'adapter à ton problème,

peux-tu me dire:

-Est-ce qu'il y a toujours 3 lignes dans tes fichiers?
-Est-ce que sa commence toujours en A2?
-Est-ce que tes cellules contenant la date sont toujours au format : d/m/yyyy?

Je te propose le code suivant. Il fait ce qui tu as décris, à savoir tester puis supprimer chaque cellule, pour autant, je ne trouve pas que l'appli' prenne tant de temps que cela.

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
Sub del()
Dim rng As Range
Dim dl As Range
Dim i As Integer
 
Application.Calculation = xlManual
 
With Worksheets("Feuil1")
    Set rng = .Range("A1")
 
    For j = 1 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row Step 2 'tu peux enlever le Step 2 si ton fichier final a un formalisme différent
        i = 0
        Do While rng.Offset(j, i) <> ""
            test = rng.Offset(j, i)
            If IsDate(rng.Offset(j, i)) Then
                If rng.Offset(j + 1, i) = "" Then
                    .Range(rng.Offset(j, i), rng.Offset(j + 1, i)).Delete (xlShiftToLeft)
                    i = i - 1
                End If
                i = i + 1
            End If
        Loop
    Next j
 
 
End With
 
Application.Calculation = xlAutomatic
 
End Sub

Je te propose donc d'essayer sur ton fichier exemple et de me dire si cela te convient !

Tiens moi au courant ! :ccool:

Me revoilà avec une solution plutôt optimisée:

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
Sub EraseEmptyCells()
Application.Calculation = xlManual
Application.ScreenUpdating = False
While fin = False
    For Each cel In ActiveSheet.Cells.SpecialCells(xlCellTypeBlanks)
            If cel.Row <> 1 Then
                If cel.Offset(-1, 0).NumberFormat = "m/d/yyyy" Then Range(cel, cel.Offset(-1, 0)).Delete Shift:=xlToLeft
            End If
    Next cel
Wend
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
 
 
Function fin() As Boolean
If Application.WorksheetFunction.CountA(Range("3:3")) = Application.WorksheetFunction.CountA(Range(Range("A2"), Range("A2").End(xlToRight))) _
And Application.WorksheetFunction.CountA(Range("3:3")) = Application.WorksheetFunction.CountA(Range(Range("A3"), Range("A3").End(xlToRight))) _
And Application.WorksheetFunction.CountA(Range("5:5")) = Application.WorksheetFunction.CountA(Range(Range("A4"), Range("A4").End(xlToRight))) _
And Application.WorksheetFunction.CountA(Range("5:5")) = Application.WorksheetFunction.CountA(Range(Range("A5"), Range("A5").End(xlToRight))) _
And Application.WorksheetFunction.CountA(Range("7:7")) = Application.WorksheetFunction.CountA(Range(Range("A6"), Range("A6").End(xlToRight))) _
And Application.WorksheetFunction.CountA(Range("7:7")) = Application.WorksheetFunction.CountA(Range(Range("A7"), Range("A7").End(xlToRight))) _
Then
    fin = True
Else
    fin = False
End If
End Function

la 2ème fonction testant si tout est bien mis en forme, à toi de modifier si le nombre de ligne varie (paramètres en dur dans le code)

26/02/2013, 16h37
motmot

Bonjour,

Merci pour vos réponses! Il faut que j'étudie tout ça. Finalement j'ai eu du mal mais j'ai trouvé une solution sans trop de lignes de code. Voci:

Citation:

Private Sub Test()
Dim RP1 As Range, RP2 As Range, RPT As Range
Dim i As Long, Fi As Long

Fi = Sheets("Feuil1").Range("A65536").End(xlUp).Row

For i = 2 To Fi
If Sheets("Feuil1").Rows(i).SpecialCells(xlCellTypeConstants).Count < 256 Then
Set RP1 = Sheets("Feuil1").Rows(i).SpecialCells(xlCellTypeBlanks).Offset(-1, 0)
Set RP2 = Sheets("Feuil1").Rows(i).SpecialCells(xlCellTypeBlanks)
Set RPT = Application.Union(RP1, RP2)
RPT.Delete xlShiftToLeft
End If
Next i

End Sub

Mais je vais aussi tester vos codes et voir ce qui est le plus rapide pour mon cas.
Encore merci à vous pour votre aide.

Cordialement

Motmot