Option Explicit
Sub Dispatch()
Dim TDon(), LD As Long, DicTrs As New Dictionary, TGDr(), LG As Long, _
C As Long, Détail, Dst As SsGr, TR(), LR As Long, Wsh As Worksheet
TDon = PlgUti(WshTrans.[A2]).Value
For LD = 1 To UBound(TDon, 1): DicTrs(TDon(LD, 1)) = True: Next LD
TGDr = PlgUti(WshGDrv.[A2]).Value: LD = 0
ReDim TDon(1 To 100000, 1 To 9)
For LG = 1 To UBound(TGDr, 1)
If DicTrs.Exists(TGDr(LG, 5)) Then
LD = LD + 1
For C = 1 To 8: TDon(LD, C) = TGDr(LG, C): Next C
TDon(LD, 9) = "Folder Owner"
For Each Détail In Split(TDon(LD, 7), ",")
If Not DicTrs.Exists(Détail) Then
LD = LD + 1
For C = 1 To 6: TDon(LD, C) = TGDr(LG, C): Next C
TDon(LD, 7) = Détail
TDon(LD, 8) = TGDr(LG, 8)
TDon(LD, 9) = "Deputy not transferred"
End If: Next Détail: End If
For Each Détail In Split(TGDr(LG, 8), ",")
If DicTrs.Exists(Détail) Then
LD = LD + 1
For C = 1 To 7: TDon(LD, C) = TGDr(LG, C): Next C
TDon(LD, 8) = Détail
Select Case True
Case TDon(LD, 1) Like "*HR": TDon(LD, 9) = "HR"
Case TDon(LD, 1) Like "*FINANCE": TDon(LD, 9) = "Finance"
Case Else: TDon(LD, 9) = "Other": End Select: End If: Next Détail: Next LG
MGigogne.DernièreLigneÀIndexer = LD
For Each Dst In Gigogne(TDon, 9)
ReDim TR(1 To 99500, 1 To 10): LR = 0
For Each Détail In Dst.Co
LR = LR + 1
For C = 1 To 8: TR(LR, C) = Détail(C): Next C, Détail
Set Wsh = ThisWorkbook.Worksheets(Dst.Id)
With Wsh.[I2:I10000]: .ClearContents: .Interior.ColorIndex = xlColorIndexNone: End With
Wsh.[A2].Resize(UBound(TR, 1), UBound(TR, 2)) = TR
Wsh.Names.Add "Flag", Wsh.[I2].Resize(LR)
Wsh.[Flag].Interior.Color = &HB8FD00
Next Dst
End Sub