Macro avec transposition

Sub Macro2_générique()
Dim sht As Worksheet, pvt As PivotTable, pvtCache As PivotCache, sTableau$, NomTCD$
X = Int(Rnd * 100000) + Second(Time)
NomTCD = InputBox("Nom du TCD?", "Test", "_TCD_" & X)
'Attention: il faut sélectionner le tableau initial
sTableau = Selection.Parent.Name & "!" & Selection.Address(ReferenceStyle:=xlR1C1)
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlConsolidation, SourceData:=sTableau)
Set pvt = pvtCache.CreatePivotTable(TableDestination:="", TableName:=NomTCD)
    pvt.DataPivotField.PivotItems("Nombre de Valeur").Position = 1
    pvt.PivotFields("Colonne").Orientation = xlHidden
    pvt.PivotFields("Ligne").Orientation = xlHidden
Range("A2").Select
Selection.ShowDetail = True
End Sub

Sub Transpose()
Dim DerLig%, indexW%, Sh, i%, j%
Application.ScreenUpdating = False                          ' Figeage écran pour aller plus vite
Sheets("Cible").Range("A2:C1000").ClearContents             ' Effacement matrice Cible
DerLig = Sheets("Origine").Range("A65500").End(xlUp).Row    ' Recherche Dernière Ligne d'Origine
indexW = 2                                                  ' IndexW : Index d'écriture dans page Cible
Set Sh = Sheets("Cible")                                    ' Affectation Sh
With Sheets("Origine")
    For i = 2 To DerLig                                     ' Pour toute les lignes de Origine
        For j = 0 To 2                                      ' Mettre sur trois lignes
            Sh.Cells(indexW + j, "A") = .Cells(i, "A")      ' L' ID
            Sh.Cells(indexW + j, "C") = .Cells(i, j + 2)    ' Origine,Processus,LP
        Next j
        Sh.Cells(indexW + 0, "B") = .Cells(1, "B")          ' Recopier les valeurs de Origine,Processus,LP sur colonne D
        Sh.Cells(indexW + 1, "B") = .Cells(1, "C")
        Sh.Cells(indexW + 2, "B") = .Cells(1, "D")
        indexW = indexW + 3                                 ' Mise à jour index écriture pour prochaine ligne Origine
    Next i
End With
End Sub

Sub traitement()
Application.ScreenUpdating = False
transposer
nettoyer
Sheets("Cible").Activate
End Sub
Private Sub transposer()
Dim f As Worksheet, pvt As PivotTable, pvtCache As PivotCache, sTab$
Set f = Sheets("Cible"): sTab = Selection.Parent.Name & "!" & Selection.Address(ReferenceStyle:=xlR1C1)
    Set pvt = ActiveWorkbook.PivotCaches.Create(SourceType:=3, SourceData:=sTab).CreatePivotTable("", "")
    pvt.DataPivotField.PivotItems("Nombre de Valeur").Position = 1
    pvt.PivotFields("Colonne").Orientation = 0: pvt.PivotFields("Ligne").Orientation = 0
Range("A2").Select: Selection.ShowDetail = True: ActiveSheet.ListObjects(1).Unlist
ActiveSheet.[A1].CurrentRegion.Cut f.[A1]: f.[A1:C1] = Array("ID", "Référentiel", "Valeurs  Cibles")
f.[B1:C1].Columns.AutoFit: f.[A2].Columns.AutoFit
End Sub
Private Sub nettoyer()
Dim f As Worksheet, Noms_F$
Noms_F = "Origine,Cible"
Application.DisplayAlerts = False
    For Each f In Worksheets
        If InStr(Noms_F, f.Name) = 0 Then
        f.Delete
    End If
Next
End Sub