Option Explicit
Private TDon(), EnsLst As Collection, EnsSuj As Collection, EnsFct As Collection
Sub TransTout()
Dim L As Long, TRés(1 To 1000, 1 To 4)
' TDon = Feuil1.[A2:E6].Value
With Feuil1.[A1].CurrentRegion: TDon = .Rows(2).Resize(.Rows.Count - 1).Value: End With
Set EnsLst = New Collection
Set EnsSuj = New Collection
Set EnsFct = New Collection
For L = 1 To UBound(TDon, 1)
TRés(L, 1) = "L" & NuméroAssumé(EnsLst, TDon(L, 1))
TRés(L, 2) = "S" & NuméroAssumé(EnsSuj, TDon(L, 2))
TRés(L, 3) = "F" & NuméroAssumé(EnsFct, TDon(L, 3))
TRés(L, 4) = "I" & L
Next L
Feuil1.[E27:H50].Value = TRés
TransLangue Feuil1.[A27:C50], "FR"
TransLangue Feuil1.[J27:L50], "EN"
Erase TDon
Set EnsLst = Nothing
Set EnsSuj = Nothing
Set EnsFct = Nothing
End Sub
Function NuméroAssumé(ByVal Ens As Collection, ByVal Clé As String) As Long
On Error Resume Next: NuméroAssumé = Ens(Clé)
If Err Then NuméroAssumé = Ens.Count + 1: Ens.Add Key:=Clé, Item:=NuméroAssumé
End Function
Sub TransLangue(ByVal RngRés As Range, ByVal Langue As String)
Dim CItm As Long, TRés(), LD As Long, Clé As String, LR As Long, _
TUtiL() As Boolean, TUtiS() As Boolean, TUtiF() As Boolean, Num As Long
ReDim TUtiL(1 To EnsLst.Count), TUtiS(1 To EnsSuj.Count), TUtiF(1 To EnsFct.Count)
CItm = IIf(Langue = "FR", 4, 5)
ReDim TRés(1 To RngRés.Rows.Count, 1 To 3)
For LD = 1 To UBound(TDon, 1)
Clé = TDon(LD, 1): Num = NuméroAssumé(EnsLst, Clé): If Not TUtiL(Num) Then TUtiL(Num) = True: _
LR = LR + 1: TRés(LR, 1) = "L" & Num: TRés(LR, 2) = Langue: TRés(LR, 3) = Clé
Clé = TDon(LD, 2): Num = NuméroAssumé(EnsSuj, Clé): If Not TUtiS(Num) Then TUtiS(Num) = True: _
LR = LR + 1: TRés(LR, 1) = "S" & Num: TRés(LR, 2) = Langue: TRés(LR, 3) = Clé
Clé = TDon(LD, 3): Num = NuméroAssumé(EnsFct, Clé): If Not TUtiF(Num) Then TUtiF(Num) = True: _
LR = LR + 1: TRés(LR, 1) = "F" & Num: TRés(LR, 2) = Langue: TRés(LR, 3) = Clé
LR = LR + 1: TRés(LR, 1) = "I" & LD: TRés(LR, 2) = Langue: TRés(LR, 3) = TDon(LD, CItm)
Next LD
RngRés.Value = TRés
End Sub