Const FEUILLE As String = "Planning Inspections"
Sub AttributionTrigramme()
Dim S As Worksheet
Dim R As Range
Dim var
Dim lastLig&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim bool As Boolean
Set S = Sheets(FEUILLE)
lastLig& = S.[a65536].End(xlUp).Row
var = S.Range("a1:iv" & lastLig& & "")
For i& = 7 To lastLig&
For j& = 11 To 256
If Trim(var(i&, j&)) <> "" Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = Trim(var(i&, j&))
T(2, cpt&) = Trim(var(i&, 3))
T(3, cpt&) = Trim(var(i&, 4))
If var(1, j&) <> "" Then
T(4, cpt&) = Trim(var(4, j&)) & Space(1) & Trim(Format(var(1, j&), " mmm yyyy"))
Else
bool = False
k& = 1
Do
If var(1, j& - k&) <> "" Then
T(4, cpt&) = Trim(var(4, j&)) & Space(1) & Trim(Format(var(1, j& - k&), " mmm yyyy"))
bool = True
End If
k& = k& + 1
Loop Until bool
End If
End If
Next j&
Next i&
Set S = Sheets.Add(after:=Sheets(Sheets.Count))
var = Array("Inspecteur", "Article", "Désignation", "Date")
Set R = S.Range(S.Cells(1, 1), S.Cells(1 + 1, UBound(T, 1)))
R = var
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
End Sub