Sub CopiePropre()
Dim i&, j&, k&, m&, u$, s$(1), x() As Variant, p As Range, Chemin$
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "\"
x = Array(Array("E7", 16), Array("E27", 21), Array("E53", 16), Array("E73", 16), Array("E93", 16), Array("E113", 16), Array("E133", 16), Array("E153", 16), Array("E173", 16), Array("E193", 16))
With Sheets("Planning d'activités recto A3"): .Copy After:=Sheets(.Name): End With
With ActiveSheet
On Error Resume Next: .Shapes("Picture 1").Delete: On Error GoTo 0
.UsedRange.Value = .UsedRange.Value
For i = UBound(x) To 0 Step -1
m = 1
With .Range(x(i)(0))
For j = 0 To 14 Step 2
Set p = .Resize(x(i)(1), 2).Offset(, j)
With .Parent.Sort
With .SortFields
.Clear
.Add Key:=p.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=p.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange p
.Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
.Apply
End With
For k = x(i)(1) To 1 Step -1
If p.Cells(k, 1) & p.Cells(k, 2) <> "" Then Exit For
Next
If k > m Then m = k
Next
.Resize(x(i)(1) - m - (x(i)(1) = m)).Offset(m).EntireRow.Hidden = True
End With
Next
On Error GoTo ErrNom1
' u = "planning" & [E1].Value & " | " & Format(Now(), "dd/mm/yyyy hh:mm:ss") 'Incorrect
u = "Planning " & Trim(Right$([E1].Value, 2)) & " | " & Format(Now(), "dd-mm-yyyy hhmmss") 'Correct
.Name = u: .Move
End With
u = "planning" & [E1].Value & " | " & Format(Now(), "dd/mm/yyyy hh:mm") 'Incorrect
' u = "Planning S" & Trim(Right$([E1].Value, 2)) & "-" & Format(Now(), "yyyymmdd-hhmmss") 'Correct
On Error GoTo ErrNom2
ActiveWorkbook.SaveAs Filename:=Chemin & u
Exit Sub
ErrNom1: s(0) = "cet onglet": s(1) = "L'onglet n'est pas renommé.": GoTo ErrNom
ErrNom2: s(0) = "ce classeur": s(1) = "Le classeur n'est pas enregistré."
ErrNom:
u = InputBox(u & vbLf & "n'est pas un nom admissible pour " & s(0) & "." & vbLf & "Modifiez-le ou donnez-en un autre :", , u)
If u = "" Then MsgBox s(1), vbCritical: Resume Next Else Resume
End Sub