Private Sub Workbook_NewSheet(ByVal Sh As Object) Application.EnableCancelKey = xlDisabled Application.ScreenUpdating = False Application.DisplayAlerts = False Dim Nb_Ligne As Long, No_Ligne As Long, Libelle_Cellule As String 'Dim Nb_Onglet As Long, Nb_Feuille As Long, Nom_Feuille As String, No_Feuille As Long, No_Onglet As Long 'Dim Lig As Integer, Wb As Workbook, Ws As Worksheet Dim Cel As Range, Formule_Cell As String, Bcl As Integer 'Dim Nom_Feuil() As String, Nom_Onglet() As String, ShCodeName As String, LongCodeName As Long 'Stop BB2_BC100517 = "BF2:BG100517" BD2_BE100517 = "BH2:BI100517" BF2_BG100517 = "BJ2:BK100517" Sh.Activate Sh.Select Debug.Print Sh.Name & " " & Sh.CodeName 'traitement du blocage de la commande ci-dessous On Error Resume Next No_Onglet = CLng(Right(Sh.CodeName, Len(Sh.CodeName) - 5)) No_Onglet = CLng(Right(Sh.CodeName, Len(Sh.CodeName) - 5)) Nb_Feuille = Sheets("Marché-Plateau").Range("L2") Nb_Onglet = Sheets("Marché-Plateau").Range("L3") 'Sheets("Marché-Plateau").Range("L2") = IIf(Nb_Feuille < Sheets("Marché-Plateau").Range("L2"), Sheets("Marché-Plateau").Range("L2"), Nb_Feuille) 'Sheets("Marché-Plateau").Range("L3") = IIf(Nb_Onglet < Sheets("Marché-Plateau").Range("L3"), Sheets("Marché-Plateau").Range("L3"), Nb_Onglet) Sh.Name = "Detail_" & Right("0" & CStr(Nb_Onglet), 2) No_Feuille = CInt(Right(Sh.Name, Len(Sh.Name) - 7)) Nom_Feuille = Sh.Name Feuille_Travail = "Feuil" & No_Onglet Debug.Print "Nb Feuille = " & Nb_Onglet & " No feuille = " & No_Feuille & " Sh.Name = " & Sh.Name Sheets(Sh.Name).Activate Sheets(Sh.Name).Columns("AP:CF").Select With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 .PatternTintAndShade = 0 End With Sheets("taf_1016_v5_Parc_TAF").Select Columns("AK:AM").Select Selection.Copy Sheets(Sh.Name).Select Columns("AK:AM").Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveWindow.LargeScroll Down:=1 Sheets(Sh.Name).Select Sheets(Sh.Name).Range("AK1,AL1,AM1").Select With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With For No_Ligne = 2 To 1048576 If Cells(No_Ligne, 37).Value <> "" Then Sheets(Sh.Name).Select Range("AK" & No_Ligne).Select ActiveCell.FormulaR1C1 = "=IF(ISBLANK(R[0]C[-27]),"""",R[0]C[21])" Range("AL" & No_Ligne).Select ActiveCell.FormulaR1C1 = "=IF(ISBLANK(R[0]C[-28]),"""",R[0]C[22])" Range("AM" & No_Ligne).Select ActiveCell.FormulaR1C1 = "=IF(ISBLANK(R[0]C[-29]),"""",R[0]C[23])" Application.FormulaBarHeight = 5 Else Exit For End If Next No_Ligne 'Stop 'Resume Flag_Ajout_Code = "NOK" Flag_Ajout_Code = AjoutCode() While Flag_Ajout_Code = "NOK" Flag_Ajout_Code = AjoutCode() Wend Sheets("Marché-Plateau").Range("L2") = Sheets("Marché-Plateau").Range("L2") + 1 Sheets("Marché-Plateau").Range("L3") = Sheets("Marché-Plateau").Range("L3") + 1 Application.EnableCancelKey = xlErrorHandler Application.ScreenUpdating = True Application.DisplayAlerts = True Exit Sub ErrorHandler: Resume End Sub Function AjoutCode() As String Application.EnableCancelKey = xlDisabled Application.ScreenUpdating = False 'Application.DisplayAlerts = False 'Application.Interactive = False Debug.Print " entree fonction ajoutcode ! " Dim Lig As Integer, Wb As Workbook, Ws As Worksheet AjoutCode = "NOK" Set Wb = ThisWorkbook ' Workbooks.Open("LeFichier") Sheets(Nom_Feuille).Select Sheets(Nom_Feuille).Range("A1").Select 'With Application.ActiveWorksheet.VBProject.VBComponents(Feuille_Travail).CodeModule With Wb.VBProject.VBComponents(Feuille_Travail).CodeModule 'With Application.ActiveWorkbook.VBComponents(Feuille_Travail).CodeModule Lig = 3 .InsertLines Lig, "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)": Lig = Lig + 1 .InsertLines Lig, " Dim Lien_Hyper As String": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, " Application.ScreenUpdating = False ": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, " Feuille_Travail = ActiveSheet.Name": Lig = Lig + 1 .InsertLines Lig, " BB2_BC100517 = " & Chr(34) & "BF2:BG100517" & Chr(34): Lig = Lig + 1 '.InsertLines Lig, " BB2_BC100517 = " & Chr(34) & BB2_BC100517 & Chr(34): Lig = Lig + 1 .InsertLines Lig, " BD2_BE100517 = " & Chr(34) & "BH2:BI100517" & Chr(34): Lig = Lig + 1 '.InsertLines Lig, " BD2_BE100517 = " & Chr(34) & BD2_BE100517 & Chr(34): Lig = Lig + 1 .InsertLines Lig, " BF2_BG100517 = " & Chr(34) & "BJ2:BK100517" & Chr(34): Lig = Lig + 1 '.InsertLines Lig, " BF2_BG100517 = " & Chr(34) & BF2_BG100517 & Chr(34): Lig = Lig + 1 Debug.Print " écriture code commencé dans fonction ajoutcode ! " .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, " Debug.Print Target.Column, Target.Row": Lig = Lig + 1 .InsertLines Lig, " Select Case Target.Column": Lig = Lig + 1 .InsertLines Lig, " Case 37": Lig = Lig + 1 .InsertLines Lig, " Worksheets(Feuille_Travail).Select": Lig = Lig + 1 .InsertLines Lig, " Lien_Hyper = Application.WorksheetFunction.VLookup(Target, Worksheets(Feuille_Travail).Range(BB2_BC100517), 2, 0) ": Lig = Lig + 1 .InsertLines Lig, " Debug.Print Lien_Hyper": Lig = Lig + 1 .InsertLines Lig, " Call Lancer_IE(Lien_Hyper)": Lig = Lig + 1 .InsertLines Lig, " Case 38": Lig = Lig + 1 .InsertLines Lig, " Worksheets(Feuille_Travail).Select": Lig = Lig + 1 .InsertLines Lig, " Lien_Hyper = Application.WorksheetFunction.VLookup(Target, Worksheets(Feuille_Travail).Range(BD2_BE100517), 2, 0) ": Lig = Lig + 1 .InsertLines Lig, " Debug.Print Lien_Hyper": Lig = Lig + 1 .InsertLines Lig, " Call Lancer_IE(Lien_Hyper)": Lig = Lig + 1 .InsertLines Lig, " Case 39": Lig = Lig + 1 .InsertLines Lig, " Worksheets(Feuille_Travail).Select": Lig = Lig + 1 .InsertLines Lig, " Lien_Hyper = Application.WorksheetFunction.VLookup(Target, Worksheets(Feuille_Travail).Range(BF2_BG100517), 2, 0) ": Lig = Lig + 1 .InsertLines Lig, " Debug.Print Lien_Hyper": Lig = Lig + 1 .InsertLines Lig, " Call Lancer_IE(Lien_Hyper)": Lig = Lig + 1 .InsertLines Lig, " Case Else": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, " End Select": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, "Application.ScreenUpdating = True ": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 .InsertLines Lig, "End Sub": Lig = Lig + 1 .InsertLines Lig, " ": Lig = Lig + 1 End With Debug.Print " fin écriture code commencé dans fonction ajoutcode ! " ActiveWindow.ScrollRow = 1 Application.FormulaBarHeight = 1 Application.EnableCancelKey = xlErrorHandler Application.ScreenUpdating = True Application.DisplayAlerts = True 'Application.RefreshDatabaseWindow AjoutCode = "ok" Debug.Print " sortie fonction ajoutcode ! " 'Application.Interactive = True Exit Function ErrorHandler: Debug.Print " ========================= > fonction resume activée ! " Resume End Function