Nekoty
XLDnaute Junior
Bonjour à tous,
Débutant en VBA, j'ai créé et me suis fait aidé pour une macro d'extraction et de tri. Cette macro est assez longue lors de son exécution.
Pourriez-vous, s'il vous plait, regader et m'aider à la simplifier.
Vous remerciant par avance.
________________________________
Sub calc_proj()
Sheets("CAL_PROJET").Select
Columns("A
Selection.Delete Shift:=xlToLeft
Columns("A
onglet = "01"
GoSub calcul
onglet = "02"
GoSub calcul
onglet = "03"
GoSub calcul
GoTo suite
calcul:
Sheets(onglet).Select
For col = 4 To 380
col_rens = Cells(5, col)
If col_rens > 0 Then
lign = lign + 100
Range(Cells(6, col), Cells(99, col)).Select
Selection.Copy
Sheets("CAL_PROJET").Select
Cells(lign, 1).Select
ActiveSheet.Paste
Sheets(onglet).Select
End If
Next
Return
suite:
Sheets("CAL_PROJET").Select
Columns("A:A").Select
ActiveWorkbook.Worksheets("CAL_PROJET").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CAL_PROJET").Sort.SortFields.Add Key:=Range("A1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("CAL_PROJET").Sort
.SetRange Range("A1:A200000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Selection.End(xlDown).Select
lig_fin = ActiveCell.Row
Range("B1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""/"",RC[-1]&""/"")-1)"
Range("B1").Select
Selection.Copy
Range(Cells(1, 2), Cells(lig_fin, 2)).Select
ActiveSheet.Paste
Calculate
Columns("A:A").Select
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").Select
Selection.Copy
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$C$1:$C$200000").RemoveDuplicates Columns:=1, Header:=xlNo
Range("C1").Select
Selection.End(xlDown).Select
lig_fin = ActiveCell.Row
Range("D1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(C[-2],RC[-1]))"
Range("D1").Select
Selection.Copy
Range(Cells(1, 4), Cells(lig_fin, 4)).Select
ActiveSheet.Paste
End Sub