Remonter un tableau automatiquement

[Ozzoun]

Bonjour,

Pouvez-vous m'expliquer la logique à suivre pour remonter un tableau automatiquement ?
Je réfléchis à des solutions avant de me lancer dans la création de mon excel..

Côté scénario, j'aurais une liste de numéros d'affaire dont certain ne serait pas forcément utile à chacun. Donc je cherche une solution où en supprimant les lignes indésirables et en exécutant un macro, on remonte toutes les lignes en haut du tableau. Pour me compliquer la tâche, sans supprimer de ligne..

Si vous pouvez m'aiguiller un petit peu

Merci d'avance.

 

[Ozzoun]

J'ai réussi à sortir quelque chose de fonctionnel, mais loin d'être correct (Exit et GoTo.... Pardon )
Si vous avez des solutions plus "propre" je suis preneur ^^

J'ai aussi un dépassement de capacité, ne connaissant pas cette erreur j'ai mis un On Error en vrac

Sub Complete()

    Dim j As Integer
    Dim i As Integer
    Dim colonne As String
    Dim cellule As String
    Dim cible As String
    On Error GoTo Error
  
  
    colonne = "A"
  
    For i = 2 To 50
        cellule = colonne & i
        If Range(cellule).Value = "" Then
            j = i + 1
            While Range(cellule).Value = ""
                cible = colonne & j
                If Not Range(cible).Value = "" Then
                    Range(cible).Select
                    ActiveCell.Cut
                    Range(cellule).Select
                    ActiveSheet.Paste
                End If
                j = j + 1
            Wend
        End If
    Next
  
Error:
          
End Sub

 

[mapomme]

Bonsoir @Ozzoun,
Bienvenu sur XLD ,

La méthode dépend de facteurs qu'on ne connait pas : Les cellules peuvent-elles contenir la chaine vide ? Les cellules contiennent-elles des formules ? Combien de cellule à examiner ? Tout cela peut orienter vers une méthode ou une autre...

Pas forcément le plus rapide mais pour une cinquantaine de ligne, c'est suffisant :

Sub Complete()
Dim xcell, xrg As Range

For Each xcell In Range("a2:a50")
   If xcell = "" Then
      If xrg Is Nothing Then Set xrg = xcell Else Set xrg = Union(xrg, xcell)
   End If
Next xcell
If Not xrg Is Nothing Then xrg.Delete xlShiftUp
End Sub

 

[Ozzoun]

Merci de ta réponse @mapomme , je vais étudier ça plus en détail.
J'ai une copie de cette liste dans une autre feuille et je me retrouve avec des #REF!
Une idée de comment résoudre ce soucis ? Passer un coup de macro pour les supprimer ?

 

[mapomme]

Re,

Si la colonne A ne contient que des valeurs, alors cette macro est beaucoup beaucoup plus rapide...

Sub Complete2()
Dim t, i As Long, n As Long

   t = Range("a2:a50000")
   For i = LBound(t) To UBound(t)
      If t(i, 1) <> "" Then n = n + 1: t(n, 1) = t(i, 1)
   Next i
   Range("a2:a50000").ClearContents
   If n > 1 Then Range("a2").Resize(n) = t
End Sub

 

[mapomme]

Merci de ta réponse @mapomme , je vais étudier ça plus en détail.
J'ai une copie de cette liste dans une autre feuille et je me retrouve avec des #REF!
Une idée de comment résoudre ce soucis ? Passer un coup de macro pour les supprimer ?

Un petit fichier test sera le bienvenu.

 

[Ozzoun]

@mapomme
Voici un petit test, j'ai pour le moment laissé ma macro très lourde en visuel, le temps d'adapter ce que tu me propose.

Data: Liste des numéros d'affaires (j'ai déjà supprimer quelque contenu pour le test), avec le bouton d’exécution de la macro.

Planning: Copie de la liste des numéros d'affaires (où je retrouve mon problème de #REF!)

 

[mapomme]

Re ,

Essayez ce code :

Sub Complete()
Dim xcell, xrg As Range

   Application.ScreenUpdating = False
   With Sheets("Data")
      If .FilterMode Then .ShowAllData
      For Each xcell In .Range("a2:a50")
         If xcell = "" Then
            If xrg Is Nothing Then Set xrg = xcell Else Set xrg = Union(xrg, xcell)
         End If
      Next xcell
      If Not xrg Is Nothing Then xrg.EntireRow.Delete xlShiftUp
   End With
   With Sheets("Planning")
      Set xrg = Nothing
      If .FilterMode Then .ShowAllData
      On Error Resume Next
      Set xrg = .Columns("b").SpecialCells(xlCellTypeFormulas, xlErrors)
      On Error GoTo 0
      If Not xrg Is Nothing Then xrg.EntireRow.Delete xlShiftUp
   End With
End Sub

 

[Ozzoun]

Très efficace en effet, juste un petit soucis.
Est-ce possible de faire de même sans faire de Delete côté Data ? Sur la Feuille Planning cela ne devrait pas être dérangeant.
Si c'est trop compliqué à gérer, je peux toujours voir pour réaménager le reste de ma feuille Date.

Merci pour l'aide

 

[mapomme]

Re,

Avec le fichier. le code est dans module1.

 

[mapomme]

Est-ce possible de faire de même sans faire de Delete côté Data ?

Je ne comprends pas. Montrez moi, svp, le résultat souhaité sur la feuille "Data".

 

[Ozzoun]

Le problème, est que j'ai quelque calcul sur cette même page.
Je peux m'adapter si jamais.

 

[mapomme]

Re,

Essayez le code ci-dessous. S'il faut faire de même pour le planning, dites le moi en précisant quelle est la dernière colonne du planning.

Sub Complete()
Dim xcell, xrg As Range

   Application.ScreenUpdating = False
   With Sheets("Data")
      If .FilterMode Then .ShowAllData
      For Each xcell In .Range("a2:a50")
         If xcell = "" Then
            If xrg Is Nothing Then Set xrg = xcell.Resize(, 2) Else Set xrg = Union(xrg, xcell.Resize(, 2))
         End If
      Next xcell
      If Not xrg Is Nothing Then xrg.Delete xlShiftUp
   End With
   With Sheets("Planning")
      Set xrg = Nothing
      If .FilterMode Then .ShowAllData
      On Error Resume Next
      Set xrg = .Columns("b").SpecialCells(xlCellTypeFormulas, xlErrors)
      On Error GoTo 0
      If Not xrg Is Nothing Then xrg.EntireRow.Delete xlShiftUp
   End With
End Sub

 

[Ozzoun]

Nickel, tout est bon
Par curiosité,il faudrait modifier quoi pour le faire également sur "Planning"
Pour la longueur, on as le premier numéro d'affaires en B8 (7 l'intitulé des colonnes) jusqu'à AI8 (AI9 est le total) sur environ 120 ligne

 

[mapomme]

(AI9 est le total)

Le total ne serait-il pas plutôt en fin de ligne en colonne AJ ?

Sinon essayez de remplacer :

If Not xrg Is Nothing Then xrg.EntireRow.Delete xlShiftUp

par :

If Not xrg Is Nothing Then xrg.EntireRow.resize(,35).offset(,7).Delete xlShiftUp