Effacement de plusieurs lignes

Bonjour

j'ai une macro visant à supprimer des enregistrements au sein de plusieurs onglets

je récupère bien les lignes concernées mais elle ne se supprime pas pour autant

j'ai tente des verifs et je récupère bien ID_project et Project Acronym + les différentes lignes concernées

toutefois seul la première ligne est effacée

'on efface le projet dans positionning si existant:
With Worksheets("Positionning")
derpos = Worksheets("Positionning").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To derpos
If (Worksheets("Positionning").Cells(i, 2) = ID_project) And (Worksheets("Positionning").Cells(i, 5) = Project_Acronym) Then
MsgBox ("Lignes Positionning " & i & "     " & ID_project & "     " & Project_Acronym)
Worksheets("Positionning").Rows(i).EntireRow.Delete
End If
Next
End With

où est mon erreur svp?

merci et bonne journée

Bonjour Darkangel,

De ce que je vois et je comprends vous ne faite que parcourir toutes les lignes d'un seul onglet.

Il manque donc une boucle pour tous les onglets

A+

Bonjour Bruno ca fait un bail :)

C'est ici un extrait de la macro car ce problème est reproduit dans chacun des cas ou il y a de multiples lignes

au début la ligne projet unique se supprime bien

ensuite la premiere ligne de l'onglet positionning se supprime mais pas les suivantes et cela se reproduit pour chacun des onglets sauf si un seul enregistrement

ici beaucoup de lignes commentées car j'essaye de faire des tests non constructifs

Private Sub Effacer_Projet_Click()
If MsgBox("Are you sure you want deleting this project", vbYesNo, "Confirmation") = vbNo Then Exit Sub
Fermer_Click

'on commence par effacer le projet lui meme:
fin = Worksheets("Projects").Range("A" & Rows.Count).End(xlUp).Row
project_Range = Worksheets("Projects").Range("A1:A" & fin).Find(ID_project).Row
Match = Worksheets("Projects").Range("C" & project_Range & ":C" & fin).Find(Project_Acronym).Row
MsgBox (Match)
'Worksheets("Projects").Rows(Match).EntireRow.Delete
MsgBox ("Projet Effacé")

'on efface le projet dans positionning si existant:
With Worksheets("Positionning")
derpos = Worksheets("Positionning").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To derpos
If (Worksheets("Positionning").Cells(i, 2) = ID_project) And (Worksheets("Positionning").Cells(i, 5) = Project_Acronym) Then
MsgBox (i)
'Worksheets("Positionning").Rows(i).EntireRow.Delete
End If
Next
'MsgBox ("Postionning Effacé")
End With

'on efface le projet dans budget si budget existant
With Worksheets("Budget")
derbudg = Worksheets("Budget").Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To derbudg
If (Worksheets("Budget").Cells(j, 1) = ID_project) Then
MsgBox (j)
'Worksheets("budget").Rows(j).EntireRow.Delete
End If
Next
'MsgBox ("Budget Effacé")
End With

'on efface le projet dans investigators
With Worksheets("Investigators")
derinvest = Worksheets("Investigators").Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To derinvest
If (Worksheets("Investigators").Cells(k, 2) = ID_project) Then
MsgBox (k)
'Worksheets("budget").Rows(k).EntireRow.Delete
End If
Next
'MsgBox ("Investigators Effacé")
End With

'on efface les WP attachés au projet
With Worksheets("WorkPackages")
derwp = Worksheets("WorkPackages").Cells(Rows.Count, "A").End(xlUp).Row
For l = 1 To derwp
If (Worksheets("WorkPackages").Cells(l, 1) = ID_project) Then
MsgBox (l)
'Worksheets("budget").Rows(l).EntireRow.Delete
End If
Next
'MsgBox ("WP Effacé")
End With

'on efface les del attachés au projet
With Worksheets("Deliverables")
derdeliv = Worksheets("Deliverables").Cells(Rows.Count, "A").End(xlUp).Row
For m = 1 To derdeliv
If (Worksheets("Deliverables").Cells(m, 1) = ID_project) Then
MsgBox (m)
'Worksheets("budget").Rows(m).EntireRow.Delete
End If
Next
'MsgBox ("Del Effacé")
End With

'on efface les périodes attachés au projet
With Worksheets("Reporting")
derreport = Worksheets("Reporting").Cells(Rows.Count, "A").End(xlUp).Row
For o = 1 To derreport
If (Worksheets("Reporting").Cells(o, 1) = ID_project) Then
MsgBox (o)
'Worksheets("Reporting").Rows(o).EntireRow.Delete
End If
Next
'MsgBox ("Périodes Effacé")
End With

'on efface l'abstract
With Worksheets("Abstract")
derabst = Worksheets("Abstract").Cells(Rows.Count, "A").End(xlUp).Row
For p = 1 To derabst
If (Worksheets("Abstract").Cells(p, 1) = ID_project) Then
'MsgBox (p)
'Worksheets("Abstract").Rows(p).EntireRow.Delete
End If
Next
'MsgBox ("Abstract Effacé")
End With

'on efface le compte bancaire associé
With Worksheets("Accounts")
deracc = Worksheets("Accounts").Cells(Rows.Count, "A").End(xlUp).Row
For q = 1 To deracc
If (Worksheets("Accounts").Cells(q, 1) = ID_project) Then
'MsgBox (q)
'Worksheets("Accounts").Rows(q).EntireRow.Delete
End If
Next
'MsgBox ("Compte bancaire Effacé")
End With

'on efface le staff associé
With Worksheets("Staff")
derstaf = Worksheets("Staff").Cells(Rows.Count, "A").End(xlUp).Row
For r = 1 To derstaf
If (Worksheets("Staff").Cells(r, 1) = ID_project) Then
MsgBox (r)
'Worksheets("Staff").Rows(r).EntireRow.Delete
End If
Next
'MsgBox ("Staff Effacé")
End With

'
''on efface le dossier associé
'
'    sFolderPath = "C:\Users\A_Forest\Desktop\TBD_Projets\Projects_Library\" & Project_Acronym & "-" & ID_project & "\"
'
'    If Right(sFolderPath, 1) = "\" Then
'    sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
'    End If
'
'    'Create FSO Object
'    Set oFSO = CreateObject("Scripting.FileSystemObject")
'
'    'Check Specified Folder exists or not
'    If oFSO.FolderExists(sFolderPath) Then
'
'          'Delete All Files
'          oFSO.DeleteFile sFolderPath & "\*.*", True
'
'          'Delete All Subfolders
'          oFSO.DeleteFolder sFolderPath & "\*.*", True
'
'     End If
'  RmDir sFolderPath

End Sub

Re,

Oui ça faisait un bail

Sinon, j'ai oublié une précision cruciale et je viens seulement de voir l'erreur

Pour supprimer des lignes, il faut faire une boucle inversée, commencer par la fin pour arriver au début, donc

With Worksheets("Positionning")
  For i = derpos To 1 Step -1
    If .Cells(i, 2) = ID_project And .Cells(i, 5) = Project_Acronym Then
      MsgBox (i)
      .Rows(i).EntireRow.Delete
    End If
  Next
End With

A+

Ah bah voila une information effectivement cruciale!

Je n’ai plus qu’à tester et voir si cela fonctionne correctement.

Merci en tout cas

En espérant que tout va bien pour vous

@+