Aide pour simplification macro

[Nekoty]

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").Select
Selection.Delete Shift:=xlToLeft

Columns("A").ColumnWidth = 30

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

 

[pierrejean]

Re : Aide pour simplification macro

Re

Pas besoin de formule

tester:

Sub calconglet()
Application.ScreenUpdating = False
liste = Array("01", "02", "03")
For m = LBound(liste) To UBound(liste)
 For col = 4 To 380
    col_rens = Sheets(liste(m)).Cells(5, col)
    If col_rens > 0 Then
        lign = lign + 100
        Sheets(liste(m)).Range(Cells(6, col).Address & ":" & Cells(99, col).Address).Copy Destination:=Sheets("CAL_PROJET").Cells(lign, 1)
    End If
 Next
Next
Sheets("CAL_PROJET").Select
lig_fin = Cells(Rows.Count, 1).End(xlUp).Row
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:A" & lig_fin)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 lig_fin = Cells(Rows.Count, 1).End(xlUp).Row
 Range("A1:A" & lig_fin).Copy
 Range("B1").PasteSpecial Paste:=xlPasteFormats
 Range(Cells(1, 2), Cells(lig_fin, 2)).FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""/"",RC[-1]&""/"")-1)"
 Columns("B:B").Copy Destination:=Range("C1")
 Set dico = CreateObject("Scripting.dictionary")
 For Each cel In Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row)
   If cel.Value <> "" Then
     x = cel.Value & "|" & cel.Font.Color & "|" & cel.Interior.Color
     dico(x) = dico(x) + 1
   End If
 Next
 a = dico.keys
 b = dico.items
 Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).ClearContents
  For n = LBound(a) To UBound(a)
   xx = Split(a(n), "|")
   Cells(n + 1, 3).Value = xx(0)
   Cells(n + 1, 3).Font.Color = CLng(xx(1))
   Cells(n + 1, 3).Interior.Color = CLng(xx(2))
   Cells(n + 1, 4) = b(n)
 Next
 Range("C" & n + 1 & ":C" & Rows.Count).Clear
 Application.ScreenUpdating = True
End Sub

 

[Nekoty]

Re : Aide pour simplification macro

re,
Merci Pierrejean, votre code fonctionne à merveille. Vous m'enlever quelques heures de mise au point de cette macro. Il faudra que je prenne du temps pour comprendre le code.

Cela a l'air si simple pour vous.

Merci encore et bonne soirée

 

[Staple1600]

Re : Aide pour simplification macro

Bonsoir à tous

POUR INFO: Nekoty : une adresse email apparaît en clair dan ton fichier joint : xxxx@arkoxxx.com
Tu devrais changer ta PJ en supprimant celle-ci dans Fichier/Informations/Personnes associées

Une simplification du code de Pierrejean au niveau du tri.
(version old school - test oK sur Excel 2013)
avec un petit bout d'endive en plus également

Sub calconglet()
Dim liste, m As Byte, col&, lig&
Application.ScreenUpdating = False
liste = Array("01", "02", "03")
For m = LBound(liste) To UBound(liste)
 For col = 4 To 380
    col_rens = Sheets(liste(m)).Cells(5, col)
    If col_rens > 0 Then
        lign = lign + 100
        Sheets(liste(m)).Range(Cells(6, col).Address & ":" & Cells(99, col).Address).Copy Destination:=Sheets("CAL_PROJET").Cells(lign, 1)
    End If
 Next
Next
With Sheets("CAL_PROJET")
lig_fin = .Cells(Rows.Count, 1).End(xlUp).Row
'ici simplication du tri
.Columns("A:A").Sort key1:=.Cells(1, 1), order1:=xlAscending
lig_fin = .Cells(Rows.Count, 1).End(xlUp).Row
 .Range("A1:A" & lig_fin).Copy
 .Range("B1").PasteSpecial Paste:=xlPasteFormats
 .Range(.Cells(1, 2), .Cells(lig_fin, 2)).FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""/"",RC[-1]&""/"")-1)"
 .Columns("B:B").Copy Destination:=.Range("C1")
 Set dico = CreateObject("Scripting.dictionary")
 For Each cel In .Range("C1:C" & .Range("C" & Rows.Count).End(xlUp).Row)
   If cel.Value <> "" Then
     x = cel.Value & "|" & cel.Font.Color & "|" & cel.Interior.Color
     dico(x) = dico(x) + 1
   End If
 Next
 a = dico.keys
 b = dico.items
 .Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).ClearContents
For n = LBound(a) To UBound(a)
   xx = Split(a(n), "|")
   .Cells(n + 1, 3).Value = xx(0)
   .Cells(n + 1, 3).Font.Color = CLng(xx(1))
   .Cells(n + 1, 3).Interior.Color = CLng(xx(2))
   .Cells(n + 1, 4) = b(n)
 Next
 .Range("C" & n + 1 & ":C" & Rows.Count).Clear
End With
Application.ScreenUpdating = True
End Sub

 

[Nekoty]

Re : Aide pour simplification macro

Bonsoir Staple,

Un peu de retard dans la lecture petit séjour à Milan.
Fichier supprimé, merci pour l'info.
J'ai testé avec 2007, ça marche très bien aussi.

Grand merci à vous tous.
Cordialement