Fonction ? meme nom sur une seule ligne

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, i&, j%, a, b, resu(), s, x
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
'---liste des noms sans doublon et valeurs concaténées---
For i = 1 To UBound(t)
  For j = 1 To ncol Step 2
    If t(i, j) <> "" Then d(t(i, j)) = d(t(i, j)) & "#" & 1 + (j + 1) / 2 & " " & t(i, j + 1)
Next j, i
If d.Count = 0 Then Exit Sub
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 1, 1) = a(i)
  s = Split(Mid(b(i), 2), "#")
  For j = 0 To UBound(s)
    x = Split(s(j))
    resu(i + 1, x(0)) = x(1)
Next j, i
'---restitution---
[A1].Resize(d.Count, UBound(resu, 2)) = resu
End Sub

Sub Copier()
With [A1:H3]
  .Copy .Resize(, 16000)
End With
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, sep1$, sep2$, i&, j%, a, b, resu(), s, x
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
sep1 = Chr(1): sep2 = Chr(2)
'---liste des noms sans doublon et valeurs concaténées---
For i = 2 To UBound(t)
  For j = 1 To ncol Step 2
    If t(i, j) <> "" Then d(t(i, j)) = d(t(i, j)) & sep1 & 1 + (j + 1) / 2 & sep2 & t(i, j + 1)
Next j, i
If d.Count = 0 Then GoTo 1
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count + 1, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 2, 1) = a(i)
  s = Split(b(i), sep1)
  For j = 1 To UBound(s)
    x = Split(s(j), sep2)
    resu(i + 2, x(0)) = x(1)
Next j, i
'---titres---
resu(1, 1) = "Nom"
For j = 2 To UBound(resu, 2)
  resu(1, j) = t(1, 2 * j - 3)
Next
'---restitution---
[A1].Resize(UBound(resu), UBound(resu, 2)) = resu
1 Columns.AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualisation des barres de défilement
End Sub

Sub TransP()
Dim dico, i As Long, j As Long, T1, T2, T3, Clé, Maxi As Long
Set dico = CreateObject("Scripting.Dictionary")
T1 = Worksheets("Feuille1").Range("A1").CurrentRegion
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        dico(T1(i, j)) = dico(T1(i, j)) + 1
    Next
Next
Maxi = 0
For Each Clé In dico.keys
    If dico(Clé) > Maxi Then Maxi = dico(Clé)
    dico(Clé) = Null
Next
ReDim T2(0 To Maxi - 1)
T3 = T2
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        If IsNull(dico(T1(i, j))) Then dico(T1(i, j)) = T3
        T2 = dico(T1(i, j))
        T2(((j + 1) / 2) - 1) = T1(i, j + 1)
        dico(T1(i, j)) = T2
    Next
Next
With Worksheets("Résultat")
.Range("A10").Resize(dico.Count, 1) = Application.Transpose(dico.keys)
.Range("B10").Resize(dico.Count, Maxi) = Application.Transpose(Application.Transpose(dico.items))
End With
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, d1 As Object, i&, j%, x$, a, b, resu(), e, n As Byte, lig&, col%
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
'---liste des noms sans doublon et concaténation n° ligne et colonne---
For i = 2 To UBound(t)
  d1.RemoveAll 'RAZ à chaque ligne
  For j = 1 To ncol Step 2
    x = t(i, j)
    If x <> "" Then
      d(x) = d(x) & "." & IIf(d1.exists(x), "", i & " ") & j + 1
      d1(x) = ""
    End If
Next j, i
If d.Count = 0 Then GoTo 1
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count + 1, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 2, 1) = a(i)
  For Each e In Split(Mid(b(i), 2), ".")
    n = InStr(e, " ")
    If n Then lig = Left(e, n)
    col = Mid(e, n + 1)
    resu(i + 2, 1 + col / 2) = t(lig, col)
Next e, i
'---titres---
resu(1, 1) = "Nom"
For j = 2 To UBound(resu, 2)
  resu(1, j) = t(1, 2 * j - 3)
Next
'---restitution---
[A1].Resize(UBound(resu), UBound(resu, 2)) = resu
1 Columns.AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualisation des barres de défilement
End Sub

Sub TransP()
Dim dico, i As Long, j As Long, T1, T2, T3,  Maxi As Long
Set dico = CreateObject("Scripting.Dictionary")
'T1 = Worksheets("Feuille1").Range("A1").CurrentRegion
T1 = Worksheets("Base").Range("A1").CurrentRegion
Maxi = (UBound(T1, 2) / 2) - 1
ReDim T2(0 To Maxi)
T3 = T2
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        If Not dico.Exists(T1(i, j)) Then dico(T1(i, j)) = T3
        T2 = dico(T1(i, j))
        T2(((j + 1) / 2) - 1) = T1(i, j + 1)
        dico(T1(i, j)) = T2
    Next
Next
With Worksheets("Résultat")
.Range("A10").Resize(dico.Count, 1) = Application.Transpose(dico.keys)
.Range("B10").Resize(dico.Count, Maxi) = Application.Transpose(Application.Transpose(dico.items))
End With
End Sub