Sub essai2()
Dim a, b(), i As Long, j As Long, x, n As Long, NbJours As Byte, myArea As Range
Application.ScreenUpdating = False
With Sheets("Feuil1").Range("A1").CurrentRegion
a = Application.Index(.Value, Evaluate("row(1:" & _
.Rows.Count & ")"), Array(1, 4, 5, 7, 8, 9))
End With
ReDim b(1 To UBound(a, 1) * 100, 1 To UBound(a, 2) + 5)
For i = 2 To UBound(a, 1)
If (a(i, 4) <> "") * (a(i, 5) <> "") * (a(i, 6) <> "") Then
x = Split(a(i, 4), vbLf)
NbJours = Day(DateSerial(a(i, 2), a(i, 3) + 1, 0))
For j = 0 To UBound(x)
n = n + 1
b(n, 1) = a(i, 1)
b(n, 4) = DateSerial(a(i, 2), a(i, 3), 1)
b(n, 5) = DateSerial(a(i, 2), a(i, 3), NbJours)
b(n, 6) = x(j)
If j = 0 Then b(n, 8) = a(i, 5)
b(n, 9) = Split(a(i, 6), vbLf)(j)
Next
End If
Next
With Sheets("Feuil3").Cells(1)
.CurrentRegion.Clear
.Resize(, 11).Value = [{"Ref Client","Typologie","Commentaire","Date début","Date fin","Produits","Activité","TVA","Prix","Type","Autres"}]
.Offset(1).Resize(n, 11).Value = b
With .CurrentRegion
.Columns(.Columns.Count + 1).EntireColumn.Insert
With .Columns(.Columns.Count + 1)
.Offset(1).Formula = _
"=if(rc1<>r[-1]c1,if(r[-1]c=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
.SpecialCells(2, 1).EntireRow.Insert
.SpecialCells(2, 2).EntireRow.Insert
On Error GoTo 0
.EntireColumn.Delete
End With
For Each myArea In .Columns(1).SpecialCells(2).Areas
myArea.CurrentRegion.Resize(, .Columns.Count).BorderAround Weight:=2
Next
.Columns(1).SpecialCells(4).EntireRow.Delete
With .Rows(1)
.Font.Bold = True
.Font.Size = 12
.Interior.ColorIndex = 40
End With
.Font.Name = "calibri"
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub