Supprimer les cellules vides d'un tableau et remonter les informations vers le haut

[bennp]

Bonjour à tous,

je souhaiterais supprimer automatiquement les cellules d'un tableau et remonter chaque informations vers le haut sans que ce soit la ligne entière qui remonte (voir exemple). et garder les noms correspondant de la 1ère colonne.

les 2 premières lignes seraient :

Foot - Ballon - rond - blanc
Foot - Crampon - long - vert

et du coup la dernière ligne :

Baseball - batte - longue - orange

quelqu'un aurait une idée pour le faire ?

merci à tous

 

[bennp]

Bon,

j'ai réussi à me débrouiller

Sub remonter()
Range("C3:C92").Select
Selection.Copy
Range("C3:C92").Offset(-1, 0).Activate
ActiveSheet.Paste

Range("D392").Select
Selection.Copy
Range("D392").Offset(-2, 0).Activate
ActiveSheet.Paste

For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(i, 2) = "" Then
Cells(i, 1).EntireRow.Delete
End If
Next i

End Sub

peut-être que quelqu'un peut essayer d’alléger le code, je vais avoir beaucoup de macro comme ça

merci

 

[cp4]

Bonjour,

Option Explicit

Sub remonter()
    Dim i As Integer
    Range("C3:C92").Copy Range("C3:C92").Offset(-1, 0)
    Range("D3:D92").Copy Range("D3:D92").Offset(-2, 0)

    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        If Cells(i, 2) = "" Then
            Cells(i, 1).EntireRow.Delete
        End If
    Next i

End Sub

 

[bennp]

Super merci,

est'il possible de faire la même chose en utilisant les noms de colonnes ? Par exemple remonter Tableau1[forme] d'une cellule vers le haut.

Je demande ça car la taille de mon tableau varie et si j'importe un tableau plus petit que la ligne 92, j'ai un message d'erreur ! Mon tableau aura toujours le même nom et les mêmes noms de colonnes.

Merci de votre aide

 

[cp4]

comme ceci petit ou grand tableau, peu importe on se réfère aux nombres de lignes de la colonne A

Option Explicit

Sub remonter()
    Dim i As Integer, dl As Long
    dl = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    With Feuil1
    .Range("C3:C" & dl).Copy .Range("C3:C" & dl).Offset(-1, 0)
    .Range("D3:D" & dl).Copy .Range("D3:D" & dl).Offset(-2, 0)

    For i = dl To 1 Step -1
        If .Cells(i, 2) = "" Then
            .Cells(i, 1).EntireRow.Delete
        End If
    Next i
End With
End Sub

 

[thebenoit59]

Bonjour bennp.
Bonjour cp4.

Une autre solution avec tableaux virtuels.

Option Explicit

Sub regroupement()
Dim a1(), a2()
Dim i&, i2&, j As Byte

With Sheets(1)
    a1 = .Range("A2:D" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).Value
End With

ReDim a2(1 To UBound(a1), 1 To UBound(a1, 2))
For i = 1 To UBound(a1)
    If Not a1(i, 2) = "" Then
        i2 = i2 + 1
        a2(i2, 1) = a1(i, 1)
        a2(i2, 2) = a1(i, 2)
        a2(i2, 3) = a1(i + 1, 3)
        a2(i2, 4) = a1(i + 2, 4)
        i = i + 2
    End If
Next i

With Sheets(1)
    .[a1].CurrentRegion.Offset(1).Clear
    .[a2].Resize(i2, UBound(a2, 2)) = a2
End With
End Sub

 

[cp4]

Bonjour thebenoit59,
https://www.excel-downloads.com/members/thebenoit59.191007/
impeccable pour un nombre de lignes important.
je t'envie car je ne maîtrise pas les tableaux.

bonne journée.

 

[thebenoit59]

Bonjour thebenoit59,
impeccable pour un nombre de lignes important.
je t'envie car je ne maîtrise pas les tableaux.

bonne journée.

A force d'entraînement tu y arriveras, c'est certain.

 

[cp4]

A force d'entraînement tu y arriveras, c'est certain.

Merci pour les encouragements thebenoit59.
Bon dimanche.

 

[job75]

Bonsoir bennp, cp4, thebenoit59,

Le VBA n'est pas indispensable, manuellement ce n'est pas très compliqué :

- commencer par supprimer les cellules C2 et D2: D3 pour aligner les textes

- trier le tableau sur la colonne B pour placer les cellules vides en bas

- sélectionner la colonne B et touche F5 => Cellules => cellules vides => OK

- clic droit sur la sélection => Supprimer => ligne entière

- pour terminer trier le tableau sur la colonne A.

Notez que les formats des cellules sont conservés.

A+

 

[job75]

Re,

Si l'on veut absolument automatiser les opérations précédentes :

Sub Tris()
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
  .Cells(2, 3).Delete xlUp: .Cells(2, 4).Resize(2).Delete xlUp
  .Sort .Columns(2), Header:=xlYes 'pour placer les cellules vides en bas
  .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .Sort .Columns(1), Header:=xlYes
  With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

C'est un peu moins rapide que la méthode de thebenoit59 mais comme je l'ai dit les formats sont conservés.

A+

 

[job75]

Re,

Pour tester sur Win 10 Excel 2013 j'ai copié la plage A2: D44 sur A45: D1048556.

La macro de thebenoit59 s'exécute en 5 secondes, la mienne en 9 secondes.

Bonne nuit.

 

[job75]

Bonjour le forum,

Si les textes en colonnes B C D sont dans un ordre quelconque c'est bien sûr plus compliqué.

Voyez les fichiers joints et ces macros :

Sub Regroupement_sans_formats()
Dim t, nlig&, ncol%, t1, i&, j%, n&, kmax&, k&
With [A1].CurrentRegion
  t = .Value2: nlig = UBound(t): ncol = UBound(t, 2)
  ReDim t1(1 To nlig, 1 To ncol)
  For i = 1 To nlig
    For j = 2 To ncol
      If t(i, j) <> "" Then Exit For
    Next j
    If j <= ncol Then
      n = n + 1
      t1(n, 1) = t(i, 1)
      kmax = 0
      For j = 2 To ncol
        For k = i To nlig
          If t(k, j) <> "" Then
            t1(n, j) = t(k, j)
            If k > kmax Then kmax = k
            Exit For
          End If
        Next k
      Next j
      i = kmax
    End If
  Next i
  Application.ScreenUpdating = False
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Rows(2).Resize(n).Interior.ColorIndex = xlNone 'efface les couleurs
  .Resize(n) = t1
  .Rows(n + 1).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
  With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Sub Regroupement_avec_formats()
Application.ScreenUpdating = False
With [A1].CurrentRegion
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Columns(1).EntireColumn.Insert
  .Columns(0).NumberFormat = "General": .Columns(0) = "=1/ISBLANK(RC[2])": .Columns(0) = .Columns(0).Value
  .Columns(0).Resize(, 3).Sort .Columns(0), xlDescending, Header:=xlYes 'pour placer les cellules vides en bas
  .Columns(0).EntireColumn.Delete
  .Columns(3).EntireColumn.Insert
  .Columns(3).NumberFormat = "General": .Columns(3) = "=1/ISBLANK(RC[1])": .Columns(3) = .Columns(3).Value
  .Columns(3).Resize(, 2).Sort .Columns(3), xlDescending, Header:=xlYes 'pour placer les cellules vides en bas
  .Columns(3).EntireColumn.Delete
  .Columns(4).EntireColumn.Insert
  .Columns(4).NumberFormat = "General": .Columns(4) = "=1/ISBLANK(RC[1])": .Columns(4) = .Columns(4).Value
  .Columns(4).Resize(, 2).Sort .Columns(4), xlDescending, Header:=xlYes 'pour placer les cellules vides en bas
  .Columns(4).EntireColumn.Delete
  On Error Resume Next 'si aucune SpecialCell
  .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Edit : ajouté If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée

Testé sur tableaux en A1: D1048556 :

- Regroupement_sans_formats => 6 secondes

- Regroupement_avec_formats => 35 secondes.

Bon dimanche.