macro marche une fois sur deux!

[jeanphi]

bonsoir


je ne comprends pas la macro ci dessous fonctionne une fois sur deux!!
je m'explique: selon certaines conditions une ligne s insère mais ca marche pas a tous les coups meme si les conditions sont les memes
kkun a t"il une reponse??
merci

Private Sub CommandButton3_Click()

Dim cell As Range

Application.ScreenUpdating = False
With Sheets("Relance")
.Range("A4" & ":" & "H" & .Range("G65536").End(xlUp).Row + 1).Clear
End With

For Each cell In Sheets("FEB").Range("E7:E" & Sheets("FEB").Range("E65536").End(xlUp).Row)

If cell.Value = "Validation ACHATS" Or cell.Value = "Traitement ACHATS" Then
If cell.Offset(0, 2) = "Oui" Then
cell.Offset(0, -3).Copy Sheets("Relance").Range("A" & Sheets("Relance").Range("A65536").End(xlUp).Row + 1)
cell.Offset(0, -1).Copy Sheets("Relance").Range("B" & Sheets("Relance").Range("B65536").End(xlUp).Row + 1)
cell.Copy Sheets("Relance").Range("C" & Sheets("Relance").Range("C65536").End(xlUp).Row + 1)
cell.Offset(0, 1).Copy Sheets("Relance").Range("D" & Sheets("Relance").Range("D65536").End(xlUp).Row + 1)
cell.Offset(0, 8).Copy Sheets("Relance").Range("E" & Sheets("Relance").Range("E65536").End(xlUp).Row + 1)
cell.Offset(0, 9).Copy Sheets("Relance").Range("F" & Sheets("Relance").Range("F65536").End(xlUp).Row + 1)
cell.Offset(0, 10).Copy Sheets("Relance").Range("G" & Sheets("Relance").Range("G65536").End(xlUp).Row + 1)
cell.Offset(0, 11).Copy Sheets("Relance").Range("H" & Sheets("Relance").Range("H65536").End(xlUp).Row + 1)
cell.Offset(0, 15).Copy Sheets("Relance").Range("I" & Sheets("Relance").Range("I65536").End(xlUp).Row + 1)
End If
End If

Next
Tri_InserLigne
Application.ScreenUpdating = True

End Sub

Sub Tri_InserLigne()
Application.ScreenUpdating = False
Dim plg As Range, plg2 As Range
Dim i As Long
If Sheets("Relance").Range("A4") = "" Then Exit Sub
With Sheets("Relance")
.Range(.Range("A4"), .Range("A4").SpecialCells(xlLastCell)).Interior.ColorIndex = xlNone
.Range("A4:" & .Range("H65536").End(xlUp).Address).Sort Key1:=.Range("F4"), Header:=xlNo
Set plg = .Range("A4:" & .Range("A65536").End(xlUp).Address)
For i = plg.Row + plg.Count - 1 To plg.Row + 1 Step -1
If Cells(i, 6) <> Cells(i - 1, 6) Then
Cells(i, 6).EntireRow.Insert
Cells(i, 1).Resize(1, 9).Interior.ColorIndex = 3
End If
Next
End With
Application.ScreenUpdating = True
End Sub

 

[bqtr]

Re : macro marche une fois sur deux!

Bonsoir jeanphi,

Essaye comme ceci :

J'ai repris le code que je t'avais fait vendredi soir avec la modif pour l'insertion des lignes.

Après différents tests ( un seul acheteur, uniquement deux, tous différents ...) ca fonctionne correctement. les acheteurs sont bien groupés si nécessaire et les lignes séparatrices en couleur sont bien placées.

Sub relance_Achat()

Dim cell As Range

Application.ScreenUpdating = False
With Sheets("Relance")
.Range("A4" & ":" & "I" & .Range("I65536").End(xlUp).Row + 1).Interior.ColorIndex = xlNone
.Range("A4" & ":" & "I" & .Range("I65536").End(xlUp).Row + 1).Clear
End With

For Each cell In Sheets("FEB").Range("E7:E" & Sheets("FEB").Range("E65536").End(xlUp).Row)
   
      If cell.Value = "Validation ACHATS" Or cell.Value = "Traitement ACHATS" Then
         If cell.Offset(0, 2) = "Oui" Then
           cell.Offset(0, -3).Copy Sheets("Relance").Range("A" & Sheets("Relance").Range("A65536").End(xlUp).Row + 1)
           cell.Offset(0, -1).Copy Sheets("Relance").Range("B" & Sheets("Relance").Range("B65536").End(xlUp).Row + 1)
           cell.Copy Sheets("Relance").Range("C" & Sheets("Relance").Range("C65536").End(xlUp).Row + 1)
           cell.Offset(0, 1).Copy Sheets("Relance").Range("D" & Sheets("Relance").Range("D65536").End(xlUp).Row + 1)
           cell.Offset(0, 8).Copy Sheets("Relance").Range("E" & Sheets("Relance").Range("E65536").End(xlUp).Row + 1)
           cell.Offset(0, 9).Copy Sheets("Relance").Range("F" & Sheets("Relance").Range("F65536").End(xlUp).Row + 1)
           cell.Offset(0, 10).Copy Sheets("Relance").Range("G" & Sheets("Relance").Range("G65536").End(xlUp).Row + 1)
           cell.Offset(0, 11).Copy Sheets("Relance").Range("H" & Sheets("Relance").Range("H65536").End(xlUp).Row + 1)
           cell.Offset(0, 15).Copy Sheets("Relance").Range("I" & Sheets("Relance").Range("I65536").End(xlUp).Row + 1)
         End If
      End If
      
Next

Tri_InserLigne
Application.ScreenUpdating = True

End Sub



Sub Tri_InserLigne()

Dim plg As Range, plg2 As Range
Dim i As Long

If Sheets("Relance").Range("A4") = "" Then Exit Sub

With Sheets("Relance")

   Set plg = .Range("F4 : F" & .Range("F65536").End(xlUp).Row)
   Set plg2 = .Range("A4" & ":" & "I" & .Range("I65536").End(xlUp).Row)
   
   plg2.Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
   
   For i = 4 To .Range("F65536").End(xlUp).Row * 2
      If .Cells(i, 6) <> .Cells(i + 1, 6) Then
         .Rows(i + 1).Insert Shift:=xlDown
         .Range("A" & i + 1 & ":" & "I" & i + 1).Interior.ColorIndex = 35
         i = i + 1
      End If
   Next
  .Range("A" & .Range("A65536").End(xlUp).Row + 1 & ":" & "I" & .Range("I65536").End(xlUp).Row + 1).Interior.ColorIndex = xlNone
End With

End Sub

A+ (pas avant la fin de la semaine)

 

[jeanphi]

Re : macro marche une fois sur deux!

merci PO et bonne semaine 😉