Algo transposition tableau VBA

DerCol = Worksheets("dataBase").Cells(2, Columns.Count).End(xlToLeft).Column + 1
TAblo = Range(Worksheets("dataBase").Cells(1, 1), Worksheets("dataBase").Cells(NbElement + 1, DerCol))

TAblo = Worksheets(1).Range("A1:" & dernière_colonne & nb_ligne)

Sub transposition_tableau()
Dim i&, j&, k&, ub&, uz1&, uz2&, v$, bs, bt, x, y, Champs(), b(), db(), z(), Cel As Range

  uz1 = Feuil1.[A1].End(xlDown).Row - 1
  uz2 = Feuil1.[A1].End(xlToRight).Column
  ReDim db(1 To uz1 + 1, 1 To uz2)
  db = Feuil1.[A1].Resize(uz1 + 1, uz2).Value

  b = Array()

  ub = -1
  For i = 3 To uz2
    If db(1, i) Like "Gr*B* Max" Then
      v = Left$(db(1, i), Len(db(1, i)) - 4)
      For j = 3 To uz2
        If v = db(1, j) Then
          ub = ub + 1
          x = Split(db(1, j), "r")
          y = Split(x(1), "B")
          ReDim Preserve b(ub)
          b(ub) = Array(i, j, CInt(y(0)), CInt(y(1)), v)
          Exit For
        End If
      Next
    End If
  Next

  ReDim z(1 To (ub + 1) * uz1, 1 To 6)

  For j = 2 To uz1 + 1
    bt = CDate(db(j, 1)): bs = CDate(db(j, 2))
    For i = 0 To ub
      k = k + 1
      z(k, 1) = b(i)(2): z(k, 2) = b(i)(3): z(k, 3) = (bt): z(k, 4) = (bs)
      z(k, 5) = db(j, b(i)(1))
      z(k, 6) = db(j, b(i)(0))
    Next
  Next

  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With

  Feuil2.[A1].CurrentRegion.Offset(1).ClearContents
  Feuil2.[A1].Resize(k, 6).Offset(1).Value = z

  Set Cel = [A1].Resize(k + 1, 6)
  With Feuil2.Sort
    With .SortFields
      .Clear
      .Add Key:=Cel.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
      .Add Key:=Cel.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    End With
    .SetRange Cel.Cells
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With

  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With

End Sub

  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With

Sub Transpose()
Dim h&, b As Byte, P As Range
h = [NTime] 'fige
b = [NBoard] 'fige
Set P = [A2].Resize(h * [NGr] * b, 6)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
P.Columns(1).FormulaR1C1 = "=N(R[-1]C1)+NOT(MOD(ROW()-2," & h & "*" & b & "))"
P.Columns(2).FormulaR1C1 = "=IF(RC1<>R[-1]C1,1,R[-1]C+NOT(MOD(ROW()-2," & h & ")))"
P.Columns(3).FormulaR1C1 = "=INDEX(dataBase!C1,MOD(ROW()-2," & h & ")+2)"
P.Columns(4).FormulaR1C1 = "=INDEX(dataBase!C2,MOD(ROW()-2," & h & ")+2)"
P.Columns(5).FormulaR1C1 = "=INDEX(OFFSET(Base,,," & h & "+1),MOD(ROW()-2," & h & ")+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00""),Base,0))"
P.Columns(6).FormulaR1C1 = "=INDEX(OFFSET(Base,,," & h & "+1),MOD(ROW()-2," & h & ")+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00"")&"" Max"",Base,0))"
P = P.Value
Range("A" & P.Rows.Count + 2 & ":F" & Rows.Count).ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub