XL 2016 Vba créattion bouton macro lecture dans tableau multifactoriel

Option Explicit

Dim lig&

Sub Effacer()
  If ActiveSheet.Name <> "User" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row
  On Error Resume Next: Application.ScreenUpdating = 0
  If n > 17 Then
    n = n + 2: Range("A18:Y" & n).Clear: Rows("18:" & n).RowHeight = 14.4
  End If
  ActiveSheet.Buttons("Étape 2").Delete
End Sub

Private Sub DoTravées()
  Dim i%
  For i = 1 To [F9] 'pour chacune des travées
    With Cells(lig, 1)
      .HorizontalAlignment = 4: .Value = "Travée " & i & " : "
      With .Offset(, 1)
        .HorizontalAlignment = 4: .IndentLevel = 1
        .Borders.Weight = xlMedium 'bordure contour
        With .Validation
          .Delete: .Add 3, , , "=" & [F7] 'liste déroulante Travée
        End With
      End With
    End With
    lig = lig + 5
  Next i
End Sub

Private Sub DoPAF()
  With Cells(lig, 1)
    .HorizontalAlignment = 4: .Value = "Paf : "
    With .Offset(, 1)
      .HorizontalAlignment = 4: .IndentLevel = 1
      .Borders.Weight = xlMedium 'bordure contour
      With .Validation
        .Delete: .Add 3, , , "=PAF" 'liste déroulante PAF
      End With
    End With
  End With
End Sub

Private Sub BtnÉtape2(b As Boolean)
  Dim G&, H&
  With Cells(lig + IIf(b, 4, -1), 1): G = .Left: H = .Top: End With
  With ActiveSheet.Buttons.Add(G, H, 62, 24)
    .Name = "Étape 2": .Caption = .Name: .OnAction = "Piquages"
  End With
End Sub

Sub TravéesPAF()
  If ActiveSheet.Name <> "User" Then Exit Sub
  Dim b As Boolean: lig = 18
  Call Effacer: Application.ScreenUpdating = 0
  Call DoTravées: b = UCase$(Trim$([F11])) = "OUI"
  If b Then DoPAF
  BtnÉtape2 b
End Sub

Option Explicit

Sub Piquages()
  If ActiveSheet.Name <> "User" Then Exit Sub
  Dim TypTrv$: TypTrv = [F7]: If TypTrv = "" Then Exit Sub
  Dim n1&: n1 = Cells(Rows.Count, 2).End(3).Row: If n1 < 18 Then Exit Sub
  Dim n2&, vx$, mx As Byte, pg As Byte, L%, i&, j&
  TypTrv = UCase$(Replace$(Replace$([F7], "_", " "), "é", "e"))
  With Worksheets("Cannes")
    With .ListObjects("T_Cannes")
      If .DataBodyRange Is Nothing Then Exit Sub
      n2 = .ListRows.Count + 1: Application.ScreenUpdating = 0
    End With
    For i = 18 To n1 Step 5
      L = Val(Cells(i, 2))
      If L > 0 Then
        mx = 0
        For j = 2 To n2
          vx = .Cells(j, 1)
          If vx = TypTrv Or vx = "PAF" Then
            If .Cells(j, 2) = L Then
              pg = .Cells(j, 3): If pg > mx Then mx = pg
            End If
          End If
        Next j
        If mx > 0 Then
          With Cells(i, 4)
            .Value = 1: .AutoFill .Resize(, mx), 2
            .Offset(1).Resize(, mx) = 1
            With .Resize(2, mx)
              .HorizontalAlignment = 4: .IndentLevel = 1: .Borders.LineStyle = 1
            End With
            With .Offset(2)
              .EntireRow.RowHeight = 38
              With .Resize(, mx)
                .HorizontalAlignment = 3: .VerticalAlignment = 1: .Orientation = 90
              End With
            End With
          End With
        End If
      End If
    Next i
  End With
  With ActiveSheet.Buttons("Étape 2")
    .Caption = "Étape 3": .OnAction = "LongCannes"
  End With
End Sub

Option Explicit

Private Sub SetCol(TC$, HA$, k%)
  Select Case TC
    Case "Souple": k = 5 + (HA = "3")
    Case "Souple sous tirants": k = 7 + (HA = "3")
    Case "Souple double"
      k = 11 + (Right$(HA, 1) = "a") + 2 * (Left$(HA, 1) = "3")
    Case "PVC_Souple": k = 13
    Case "PVC": k = 12
  End Select
End Sub

Sub LongCannes()
  If ActiveSheet.Name <> "User" Then Exit Sub
  Dim TypTrv$: TypTrv = [F7]: If TypTrv = "" Then Exit Sub
  Dim TypCan$: TypCan = [N9]: If TypCan = "" Then Exit Sub
  Dim HtrArr$: HtrArr = [N7]
  If Left$(TypCan, 6) = "Souple" And HtrArr = "" Then Exit Sub
  Dim n1&: n1 = Cells(Rows.Count, 2).End(3).Row: If n1 < 18 Then Exit Sub
  TypTrv = UCase$(Replace$(Replace$([F7], "_", " "), "é", "e"))
  Dim k%: SetCol TypCan, HtrArr, k: If k = 0 Then Exit Sub
  Dim s$, m%, d%, n2&, vx$, pg As Byte, L%, i&, p&, j&: m = Columns.Count
  With Worksheets("Cannes")
    With .ListObjects("T_Cannes")
      If .DataBodyRange Is Nothing Then Exit Sub
      n2 = .ListRows.Count + 1: Application.ScreenUpdating = 0
    End With
    For i = 18 To n1 Step 5
      L = Val(Cells(i, 2))
      If L > 0 Then
        d = Cells(i, m).End(1).Column - 3: s = String$(d, "1"): p = i + 1
        For j = 1 To d
          If Cells(p, j + 3) <> 1 Then Mid$(s, j, 1) = "0"
        Next j
        p = p + 1
        For j = 2 To n2
          vx = .Cells(j, 1)
          If vx = TypTrv Or vx = "PAF" Then
            If .Cells(j, 2) = L Then
              pg = .Cells(j, 3)
              If Mid$(s, pg, 1) = "1" Then Cells(p, pg + 3) = .Cells(j, k) & "  "
            End If
          End If
        Next j
      End If
    Next i
  End With
End Sub

 With Cells(i - 1, 4)    
      If i = 1 Then
          .Value = 1
          Else
          .Value = pg: .AutoFill .Resize(, mx), 2

With Cells(i, 4)
  .Value = 1: .AutoFill .Resize(, mx), 2
End With

 For i = 18 To n1 Step 5

 For i = 1 To [F9] + 1

pgmx =1

[...]

ReDim Preserve tabTrv(i)
              tabTrv(i) = pg
[...]

pgmx = tabTrv(i) + pgmx

If TypCan = "tête_en_haut" Then ...

 If [N9] = "tête_en_haut" Then ...

 Dim TypCan$: TypCan = [N9] ...

Option Explicit

Sub Tubes()
  If ActiveSheet.Name <> "User" Then Exit Sub
  Dim n1&: n1 = Cells(Rows.Count, 2).End(3).Row: If n1 < 18 Then Exit Sub
  Dim m%, d%, n2%, vx%, L%, i&, p&, j&, r&, t&, k%, b As Byte
  m = Columns.Count: Application.ScreenUpdating = 0
  With Worksheets("Tubes")
    With .Columns
      .ClearContents: .Interior.ColorIndex = -4142
      .Borders.LineStyle = -4142: .ColumnWidth = 7
    End With
    .Columns(1).ColumnWidth = 5: k = 3
    For i = 18 To n1 Step 5
      L = Val(Cells(i, 2))
      If L > 0 Then
        d = Cells(i, m).End(1).Column - 3: p = i + 2: n2 = 0: r = 1
        For j = 1 To d
          vx = Cells(p, j + 3)
          If vx > 0 Then
            b = 0
            If n2 > 0 Then
              For t = 1 To n2
                With .Cells(t + 1, k - 1)
                  If .Offset(, 1) = vx Then .Value = .Value + 1: b = 1: Exit For
                End With
              Next t
            End If
            If b = 0 Then
              r = r + 1: .Cells(r, k) = vx: .Cells(r, k - 1) = 1: n2 = n2 + 1
            End If
          End If
        Next j
        With .Cells(2, k - 1)
          .EntireColumn.ColumnWidth = 5: .Offset(, 2).EntireColumn.ColumnWidth = 6
          With .Resize(n2, 2)
            .Borders.LineStyle = 1: .Interior.Color = 14211288
          End With
          .Interior.ColorIndex = -4142: k = k + 3
        End With
      End If
    Next i
    .Select
  End With
End Sub

If ActiveSheet.Name <> "User" Then Exit Sub 'si la feuille active est différente de user alors ne pas réalisé le code ?

If Left$(TypCan, 6) = "Souple" And HtrArr = "" Then Exit Sub 'si typcan = quelque chose mais hauteur arroseur rien alors partir ?

Option Explicit: Option Base 1

Sub Extraction()
  If ActiveSheet.Name <> "Montage" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 5).End(3).Row: If n < 3 Then Exit Sub
  Dim T1, T2, rg As Byte, i&, j&
  T1 = Range("B3:E" & n): n = n - 2: ReDim T2(n, 3): j = 1
  For i = 1 To n
    rg = T1(i, 4)
    If rg > 0 Then
      T2(j, 1) = T1(i, 2): T2(j, 2) = T1(i, 3)
      T2(j, 3) = rg & "×" & T1(i, 1): j = j + 1
    End If
  Next i
  Application.ScreenUpdating = 0
  With Worksheets("Extract")
    .Columns("B:D").ClearContents: .[B2].Resize(j - 1, 3) = T2
    .Select
  End With
End Sub