Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.

[kalem]

Bonjour à toute la communauté,
Quelques soucis avec mon fichier de gestion de livres... Sur une feuille "en cours", j'indique tous les achats de livres possibles. Une fois la liste traitée, je voulais que tous les titres sélectionnés comme "rejetés" soit placés dans une feuille à part, et ceux marqués "OKLIVRE" soient transférés dans une feuille "Livres". Pour cette dernière feuille, il fallait donc enchaîner copie des lignes concernées + suppression des lignes sur la feuille "en cours".
La macro fonctionne, mais avec un souci : dans la feuille "livres" obtenue, les titres apparaissent, mais après de nombreuses lignes vides.
Je souhaite donc ajouter une nouvelle macro pour supprimer les lignes vides, mais à part le transfert des lignes, rien ne se passe, la dernière macro ne fonctionne pas...
Si quelqu'un peut m'indiquer l'erreur, je lui en serais très reconnaissante ! Merci d'avance.
Voici mon code :

Sub Deplacer_livres()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
 
Sheets("En cours").Activate
Col = "I"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Livres").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "A"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
Call Deplacer_rejets
End Sub
Sub Deplacer_rejets()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
 
Sheets("En cours").Activate
Col = "H"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "Rejeté" Then
            NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Rejetés").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "Rejeté" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "A"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
Call supprimer_lignes_vides
End Sub
Sub supprimer_lignes_vides()

Dim RowNumber As Integer
 
    Sheets("Livres").Activate
 
    RowNumber = Cells.SpecialCells(xlCellTypeLastCell).Row
 
    Do While RowNumber > 0
 
        If Rows(RowNumber).Find("*") Is Nothing Then Rows(RowNumber).Delete
 
        RowNumber = RowNumber - 1
 
    Loop
 
 
End Sub

 

[mapomme]

Bonjour @kalem ,

Après publication de 72 messages avant ce dernier, ne remarquez-vous pas que quelque chose fait défaut dans le 73ème ?

Indice :

• Mon premier est unique
• Mon second n'est vraiment pas beaucoup
• Mon troisième sert de support au golf
• Souvent à la première rentrée de mon quatrième, les gamins pleurent
• Mon cinquième l'a opportunément bien bonne
• Et mon tout motive les potentiels répondeurs d'XLD à s’intéresser à la question

Et c'est : un peu tee classe heure

 

[kalem]

Bonjour,
J'ai nettoyé le fichier, voici une version, si ça peut aider...
Merci, à charge de revanche !

 

[ARMAEL]

voici la version corrigé