'---vérification des doublons---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[B2].CurrentRegion 'à adapter
For i = 2 To P.Rows.Count
For j = 4 To 6
x = LCase(P(i, j) & P(i, 7) & P(1, j))
If d.exists(x) Then MsgBox "Doublon sur '" & P(i, j) & "' pour le N° " & d(x) & " et le N° " & P(i, 1) & " !", 48: Exit Sub
d(x) = P(i, 1) 'mémorise le N°
Next j, i
Merci Marcel, c'est génialBonjour,
Une proposition en pièce jointe.
Sub Creation_Feuilles()
Dim F As Worksheet, i&, d As Object, P As Range, ncol%, j%, x$, k%, lig&
Set F = Sheets("Planning")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppression des feuilles---
F.Move Before:=Sheets(1)
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
'---création et remplissage des feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[B2].CurrentRegion 'à adapter
ncol = P.Columns.Count
For i = 2 To P.Rows.Count
For j = 4 To 6 'colonnes à adapter
x = Application.Proper(Trim(P(i, j))) 'NOMPROPRE
If x <> "" Then
If Not d.exists(x) Then
Sheets.Add After:=Sheets(1)
Sheets(2).Name = x
For k = Sheets.Count To 3 Step -1
If x > Sheets(k).Name Then Sheets(x).Move After:=Sheets(k): Exit For 'classement des feuilles
Next k
With Sheets(x)
For k = 1 To ncol
.Columns(k).ColumnWidth = P(1, k).ColumnWidth 'largeurs des colonnes
Next
P.Rows(1).Copy .Cells(1)
End With
End If
d(x) = d(x) + 1
lig = d(x) + 1
With Sheets(x).Cells(lig, 1)
P.Rows(i).Copy .Cells
.Value = P(i, 1) 'remplace la formule par la valeur
With .Resize(, ncol).Interior
If lig Mod 2 Then .ColorIndex = xlNone Else .Color = RGB(221, 235, 247) 'bleu clair
End With
End With
End If
Next j, i
F.Activate
End Sub
Merci beaucoupBonjour SAMESS, Marcel32, Bruno,
Au départ seule la feuille "Planning" est nécessaire.
Voyez le fichier joint et la macro du bouton :
A+VB:Sub Creation_Feuilles() Dim F As Worksheet, i&, d As Object, P As Range, ncol%, j%, x$, k%, lig& Set F = Sheets("Planning") Application.ScreenUpdating = False Application.DisplayAlerts = False '---suppression des feuilles--- F.Move Before:=Sheets(1) For i = Sheets.Count To 2 Step -1 Sheets(i).Delete Next i '---création et remplissage des feuilles--- Set d = CreateObject("Scripting.Dictionary") Set P = F.[B2].CurrentRegion 'à adapter ncol = P.Columns.Count For i = 2 To P.Rows.Count For j = 4 To 6 'colonnes à adapter x = Application.Proper(Trim(P(i, j))) 'NOMPROPRE If x <> "" Then If Not d.exists(x) Then Sheets.Add After:=Sheets(1) Sheets(2).Name = x For k = Sheets.Count To 3 Step -1 If x > Sheets(k).Name Then Sheets(x).Move After:=Sheets(k): Exit For 'classement des feuilles Next k With Sheets(x) For k = 1 To ncol .Columns(k).ColumnWidth = P(1, k).ColumnWidth 'largeurs des colonnes Next P.Rows(1).Copy .Cells(1) End With End If d(x) = d(x) + 1 lig = d(x) + 1 P.Rows(i).Copy Sheets(x).Cells(lig, 1) With Sheets(x).Cells(lig, 1).Resize(, ncol).Interior If lig Mod 2 Then .ColorIndex = xlNone Else .Color = RGB(221, 235, 247) 'bleu clair End With End If Next j, i F.Activate End Sub
Merci jop75Je viens de corriger la macro et le fichier de mon post #5.
J'avais en effet oublié de remplacer la formule du N° en colonne A par la valeur
Le fichier du post #4 a été modifié, téléchargez-le.
Bonjour job75,le forum,Bonjour SAMESS, le forum,
Sur le fichier que j'ai joint il y a des doublons de dates dans 5 feuilles sur 6.
Dites-nous comment il faudrait modifier la feuille "Planning".
En effet ça ne sert à rien de balancer des messages dans la nature si l'on ne dit pas ce qu'il faut faire.
A+
pas de Modification sur la feuille "planning"Tout ça n'est guère cohérent et vous ne répondez pas à ma question.
Comment faut-il corriger la feuille "Planning ?"
Alors on se contentera de repérer les doublons, voyez ce fichier (2).pas de Modification sur la feuille "planning"
merci encore une fois job75 mais possible en cas on a des doublent le fichier sera supprimé ?.Alors on se contentera de repérer les doublons, voyez ce fichier (2).