Sub xx()
Dim Szero As Worksheet
Dim S As Worksheet
Dim Rzero As Range
Dim R As Range
Dim C As Range
Dim C2 As Range
Dim Ville$
Dim i&
Dim j&
Dim T_Ranges() As Range
Dim SH As Shape
Dim REC As Excel.Rectangle
'---
If TypeName(Selection) <> "Range" Then Exit Sub
Set Szero = ActiveSheet
Set Rzero = Selection
ReDim T_Ranges(1 To Rzero.Columns.Count - 1)
'---
Application.ScreenUpdating = False
Set S = Sheets.Add(after:=Szero)
For j& = 2 To Rzero.Columns.Count
Set Rzero = Range(Rzero.Cells(1, 1), Rzero.Cells(Rzero.Rows.Count, 1))
Ville$ = Rzero.Offset(-1, 0).Cells(1, j&)
Set Rzero = Application.Union(Rzero, Rzero.Offset(0, j& - 1))
Rzero.Copy
'---
If R Is Nothing Then Set R = S.[b2]
R.PasteSpecial
'---
Set T_Ranges(j& - 1) = Selection
'--- Bornes de calage ---
R.Offset(0, -1) = "Debut_" & Ville$
R.Offset(Rzero.Rows.Count - 1, -1) = "Fin_" & Ville$
'---
Set R = S.Range("B" & S.UsedRange.Rows.Count + 4 & "")
Next j&
Application.CutCopyMode = False
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° Aménagement de la plage copiée (feuille temporaire) °°°
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
With S.Cells
.Font.Name = "Calibri"
.Font.Size = 9
End With
S.Columns(3).Insert Shift:=xlToRight
S.Columns(3).Insert Shift:=xlToRight
Set R = S.UsedRange
For i& = 2 To R.Rows.Count + 1
Set C = S.Cells(i&, 2)
If C <> "" Then
C = Replace(C, " ", vbLf)
'---
Set C = C.Offset(0, 3)
Set C2 = C.Offset(0, -2)
'---
If C >= 0 Then
C.Font.Color = 5287936
C.HorizontalAlignment = xlLeft
'---
C2 = 8
With C2.Font
.Color = 5287936
.Name = "Webdings"
End With
'---
Set C2 = C2.Offset(0, 1)
C2 = "+"
C2.Font.Color = 5287936
C2.HorizontalAlignment = xlRight
Else
C.Font.Color = vbRed
C.HorizontalAlignment = xlLeft
'---
C2 = 8
With C2.Font
.Color = vbRed
.Name = "Webdings"
End With
'---
Set C2 = C2.Offset(0, 1)
C2 = " "
C2.Font.Color = vbRed
C2.HorizontalAlignment = xlRight
End If
End If
Next i&
'---
With S.Cells
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
S.Columns(1).ColumnWidth = 40
ActiveWindow.DisplayGridlines = False
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'--- Création du rectangle arrondi ---
For i& = LBound(T_Ranges) To UBound(T_Ranges)
Set R = T_Ranges(i&)
Set SH = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, _
Left:=R.Left - 10, Top:=R.Top - 10, Width:=R.Width + 20, Height:=R.Height + 20)
SH.Fill.Transparency = 1
Set REC = SH.OLEFormat.Object
REC.Border.Color = 4626167
REC.Interior.Color = vbWhite
Next i&
'--- Nettoyage ---
S.[a1].Select
Application.ScreenUpdating = True
End Sub
