Pardo Renfield....
Je vais essayé de te faire une séléction de ce qui ralenti le plus (cela dit si les autres veulent bien regarder en global la macro ça serait top)
1) "Scann" de toutes les lignes pour retirer les doublons et ainsi ne garder qu'un exemplaire du titre de chaque sous chapitre
Sheets("Calcul").Select
NouvNbreLignes = Application.CountA(Range("A1:A65536")) + 4
Sheets("Calcul").Range(Cells(5, 3), Cells(NouvNbreLignes, 3)).Select
Selection.Copy
Sheets("Choix Chapitres").Select
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(5, 2).Select
ActiveCell.FormulaR1C1 = "=PROPER(RC[-1])"
Selection.AutoFill Destination:=Range(Cells(5, 2), Cells(NouvNbreLignes, 2)), Type:=xlFillDefault
Range(Cells(5, 2), Cells(NouvNbreLignes, 2)).Select
Application.CutCopyMode = False
Selection.Copy
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A5").Select
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
While ActiveCell <> ""
If ActiveCell = donnee1 Then
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
Else
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
End If
Wend
2) Création de CheckBox dans une colonne pour toutes les lignes (parfois il y a plus de 200lignes....)
Pour les x feuilles présentes dans l'analyse que souhaite faire l'utilisateur on se retrouve avec ca :
Sub InsertionCheckFeuilx()
Dim x As Integer
Dim i As Integer
'Boucle de 1 à Compteur, pour répéter l'opération sur toutes les feuilles concernées.
For x = 1 To Compteur
Worksheets(x).Select
NbreLignes = Application.CountA(Range("E1:E65536")) + 3
Range("T4").Select
ActiveCell.FormulaR1C1 = "Pris en compte"
With ActiveCell.Characters(Start:=1, Length:=14).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("T4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Range(Cells(5, 20), Cells(NbreLignes, 20)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
For i = 5 To NbreLignes
Worksheets(x).Activate
Cells(i, 20).Select
t = ActiveCell.Top
l = ActiveCell.Left
Set obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=l + 30, Top:=t + 2, Width:=10, Height:=10 _
)
Next i
NbreTaches = NbreLignes - 4
For k = 1 To NbreTaches
Worksheets(x).OLEObjects(k).Object.Value = True
Next k
Cells(5, 21).Select
ActiveCell.FormulaR1C1 = "TRUE"
Selection.AutoFill Destination:=Range("U5:U" & NbreLignes & ""), Type:=xlFillDefault
ActiveSheet.Buttons.Add(1508.25, 20.25, 57.75, 15.75).Select
Selection.OnAction = "Bouton2_QuandClic"
Selection.Characters.Text = "Mise à jour"
With Selection.Characters(Start:=1, Length:=11).Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("U:U").Select
Selection.Font.ColorIndex = 2
Next x
End Sub
Voila je pense que la se trouvent les 2principaux points noirs. Après le reste doit pas être trop méchant