kalem
XLDnaute Junior
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 :
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 :
VB:
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