Ventiler les donnes suivant des critères

bonjour ,

je suis a la recherche de solution pour améliorer mon code vba excel

Dim lastrow As Integer
Dim dernierefeuille As Integer
Dim derniereligne As Integer
Dim nbfeuilles As Long
nbfeuilles = ThisWorkbook.Sheets.Count

Call CREA_Cliquer
Application.CutCopyMode = False

Application.ScreenUpdating = False

For j = 6 To nbfeuilles
Sheets(j).Select
lastrow = Range("A7").End(xlUp).Row
For i = lastrow To 5 Step -1
Sheets(j).Select
Rows(i).Select
Selection.Delete shift:=xlUp
Next i
Sheets("PLANNING 2").Select
derniereligne = Range("A35").End(xlUp).Row
For k = 4 To derniereligne
Sheets("PLANNING 2").Select
If Sheets(j).Name = Cells(k, 1).Value Then
Rows(k).Select
Selection.Copy
Sheets(j).Select
lastrow = Range("A6").End(xlUp).Row + 1
Cells(lastrow, 1).Select

ActiveSheet.Paste

Sheets("PLANNING 2").Select
Range("I4:AM4").Select
Selection.Copy
Sheets(j).Select
Range("i4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Selection.NumberFormat = "[$-40C]d-mmm;@"
Range("N11").Select
End If

Next k

Next j

Sheets("PLANNING 1").Select
Application.CutCopyMode = True
End Sub

Sub CREA_Cliquer()

Dim feuil As Worksheet
Application.ScreenUpdating = False
For Each feuil In Sheets

If feuil.Name <> "PLANNING 1" Then
If feuil.Name <> "PLANNING 2" Then
If feuil.Name <> "MISSIONS" Then
If feuil.Name <> "suivi de présence" Then
If feuil.Name <> "ACCEUIL" Then
Application.DisplayAlerts = False

feuil.Delete

End If
End If
End If
End If
End If

Next

Dim cellule As Range
Sheets("PLANNING 2").Select
For Each cellule In Range("A12", Range("A64").End(xlUp))
If cellule.Value <> "" Then
'Sheets.Add After:=Sheets(Sheets.Count)
Sheets("MISSIONS").Copy after:=Worksheets(Sheets.Count)
ActiveSheet.Name = cellule.Value
'ActiveSheet.Range("M3").Value = cellule.Value

'Cells.Select
' Selection.ColumnWidth = 4
' With Selection
'.VerticalAlignment = xlBottom
'.WrapText = False
'.Orientation = 90
'.AddIndent = False
' .IndentLevel = 0
'.ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
' End With
End If
Next cellule

Application.ScreenUpdating = True
End Sub

Voici le fichier

Bonjour Joel54,

Votre fil est marqué comme résolu, est-ce bien le cas !?

A+

bonjour bruno non erreur

Re,

Alors plusieurs choses

1) lorsque vous mettez du code sur le forum et conformément à la charte,
merci de le mettre entre balises grâce au bouton </>

2) Je ne vois le code nulle part

3) Votre classeur semble avoir un souci
"Feuil1" est considéré comme un classeur !?

A+

non bruno