Const NOM_FEUILLE_FUSION As String = "EDT FUSIONNER"
Sub FusionnerEDT()
Dim S As Worksheet
Dim R As Range
Dim var
Dim i&
Dim j&
Dim deb&
Dim fin&
Dim nbCol&
Dim A$
Dim Hdeb As Date
Dim Hfin As Date
Set S = Sheets("EDT")
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[a2].End(xlDown).Row, S.[c1].End(xlToRight).Column))
nbCol& = R.Columns.Count
R.Copy
Set S = Sheets.Add
On Error Resume Next
Do
Err.Clear
i& = i& + 1
S.Name = NOM_FEUILLE_FUSION & Space(1) & i&
Loop Until Err = 0
On Error GoTo Erreur
Application.ScreenUpdating = False
With S.[a1]
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[a2].End(xlDown).Row + 1, S.[a21].End(xlToRight).Column))
var = R
For j& = 3 To UBound(var, 2) Step 2
deb& = 2
For i& = 2 To UBound(var, 1) - 1
If var(i&, j&) <> var(i& + 1, j&) Then
Set R = S.Range(S.Cells(deb&, j&), S.Cells(i&, j&))
R.ClearContents
R.MergeCells = True
R.HorizontalAlignment = xlCenter
R.VerticalAlignment = xlCenter
R.WrapText = True
'--- Construction de la chaîne ---
A$ = var(i&, j&) & Chr(10)
A$ = A$ & var(i&, j& + 1) & Chr(10)
'°°° Heure de début et heure de fin °°°
Hdeb = CDate(S.Range(S.Cells(deb&, 2), S.Cells(deb&, 2)))
Hfin = CDate(S.Range(S.Cells(i&, 2), S.Cells(i&, 2)))
A$ = A$ & "de " & Format(Hdeb, "hh:mm") & " à " & Format(Hfin, "hh:mm") & Chr(10)
A$ = A$ & "soit " & Format(Hfin - Hdeb, "hh:mm")
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
R = A$
deb& = i& + 1
End If
Next i&
Next j&
For i& = nbCol& To 3 Step -2
S.Columns(i&).Delete Shift:=xlToLeft
Next i&
S.[a1].Select
Erreur:
Application.ScreenUpdating = True
End Sub