Aide pour simplification macro

Nekoty

Nekoty

XLDnaute Junior
:confused:

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

Columns("A:D").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
 
Trier par date Trier par votes
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Aide pour simplification macro

Bonjour à tous.


gosselien à dit:
Bonjour,

les bons programmeurs ici vont , avec raison, te demander un fichier exemple pour y voir + clair :)
Un code seul n'est pas explicite :)

P.
Cliquez pour agrandir...
Entièrement d'accord !
  • On ne sait pas ce qu'est censé faire le code.
  • On n'a pas de support pour voir ce qui se passe.


À tout hasard et sans garantie :​
Code: 
Sub calc_proj()
Dim onglet$, lig_fin&, col&, lign&, col_rens
  With Sheets("CAL_PROJET")
    .Columns("A").Delete Shift:=xlToLeft
    .Columns("A").ColumnWidth = 30
  End With
  onglet = "01"
  GoSub calcul
  onglet = "02"
  GoSub calcul
  onglet = "03"
  GoSub calcul
  With Sheets("CAL_PROJET")
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With .Sort
      .SetRange Range("A1:A200000")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
    lig_fin = .Range("A1").End(xlDown).Row
    .Range("B1").FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""/"",RC[-1]&""/"")-1)"
    .Range("B1").Copy Destination:=.Range(.Cells(1, 2), .Cells(lig_fin, 2))
    Calculate
    .Columns("A:A").Copy Destination:=.Columns("B:B")
    .Columns("C:C").Value = .Columns("B:B").Value
    .Range("$C$1:$C$200000").RemoveDuplicates Columns:=1, Header:=xlNo
    lig_fin = .Range("C1").End(xlDown).Row
    .Range("D1").FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(C[-2],RC[-1]))"
    .Range("D1").Copy Destination:=.Range(Cells(1, 4), Cells(lig_fin, 4))
  End With
Exit Sub
calcul:
  With Sheets(onglet)
    For col = 4 To 380
      col_rens = .Cells(5, col).Value
      If col_rens > 0 Then
        lign = lign + 100
        .Range(.Cells(6, col), .Cells(99, col)).Copy Destination:=Sheets("CAL_PROJET").Cells(lign, 1)
      End If
    Next
  End With
  Return
End Sub


Bonne journée.


ℝOGER2327
#7866

Lundi 23 Palotin 142 (Saints Quatrezoneilles, Herdanpo, Mousched-Gogh, Palotins - fête Suprême Quarte)
23 Floréal An CCXXIII, 5,6976h - bourrache
2015-W20-2T13:40:27Z
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Aide pour simplification macro

Re...


Nekoty à dit:
(...)

J'ai joint une copie allégé de mon fichier.

(...)
Cliquez pour agrandir...
Vu ! Essayez ceci :​
Code: 
Sub calc_proj()
Dim onglet$, lig_fin&, col&, lign&, col_rens
  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
  With Sheets("CAL_PROJET")
    .Columns("A").Delete Shift:=xlToLeft
    .Columns("A").ColumnWidth = 30
  End With
  onglet = "01"
  GoSub calcul
  onglet = "02"
  GoSub calcul
  onglet = "03"
  GoSub calcul
  With Sheets("CAL_PROJET")
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With .Sort
      .SetRange Range("A1:A200000")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
    lig_fin = .Range("A1").End(xlDown).Row
    .Columns("A:A").Copy Destination:=.Columns("B:C")
    .Range(.Cells(1, 2), .Cells(lig_fin, 2)).FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""/"",RC[-1]&""/"")-1)"
    .Columns("C:C").Value = .Columns("B:B").Value
    .Range("$C$1:$C$200000").RemoveDuplicates Columns:=1, Header:=xlNo
    lig_fin = .Range("C1").End(xlDown).Row
    .Range("D1").FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(C[-2],RC[-1]))"
    .Range("D1").Copy Destination:=.Range(Cells(1, 4), Cells(lig_fin, 4))
  End With
  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
Exit Sub
calcul:
  With Sheets(onglet)
    For col = 4 To 380
      col_rens = .Cells(5, col).Value
      If col_rens > 0 Then
        lign = lign + 100
        .Range(.Cells(6, col), .Cells(99, col)).Copy Destination:=Sheets("CAL_PROJET").Cells(lign, 1)
      End If
    Next
  End With
  Return
End Sub


Bonne soirée.


ℝOGER2327
#7867

Lundi 23 Palotin 142 (Saints Quatrezoneilles, Herdanpo, Mousched-Gogh, Palotins - fête Suprême Quarte)
23 Floréal An CCXXIII, 6,4297h - bourrache
2015-W20-2T15:25:52Z
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Aide pour simplification macro

Bonjour Nekoty, ROGER

Un essai

Code: 
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")
 ActiveSheet.Range("$C$1:$C$" & lig_fin).RemoveDuplicates Columns:=1, Header:=xlNo
 ActiveSheet.Range("$D$1:$D$" & lig_fin).FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(C[-2],RC[-1]))"
 Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Nekoty

Nekoty

XLDnaute Junior
Re : Aide pour simplification macro

Bonjour Pierrejean, Roger,

Merci de vous être penché sur mon problème.
Pierrejean, votre macro tourne en 4s au lieu des 15s pour 7 onglets, c'est vraiment super. merci beaucoup.

Si je peux me permettre, je viens de me rendre compte dans ma macro que lors de la suppression des doublons il ne prend pas en compte les changement de couleur des cellules. J'ai essayé des macro de boisgontier, mais je ne comprends pas le fonctionnement du code pour l'adapter à mon tableau.

Auriez-vous une idée, s'il vous plait.

Vous remerciant encore :)
Cordialement
 
Vote positif 0 Vote négatif
Nekoty

Nekoty

XLDnaute Junior
Re : Aide pour simplification macro

Re,

Dans le tableau nous gérons des numéros de projets et ces numéros peuvent être utilisés dans différentes activités qui sont gérées par code couleur (couleur & fond).

Merci Pierrejean
 
Dernière édition:
Vote positif 0 Vote négatif
Nekoty

Nekoty

XLDnaute Junior
Re : Aide pour simplification macro

Merci,

quand la macro effectue la suppression des doublons, elle ne prend en compte que la valeur des cellules et occulte la couleur et le fond.

Capture.PNG
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    3.2 KB · Affichages: 21
  • Capture.PNG
    Capture.PNG
    3.2 KB · Affichages: 18
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Aide pour simplification macro

Re

OK Alors teste cela

Code: 
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) = x
   End If
 Next
 a = dico.keys
 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))
 Next
 Range("C" & n + 1 & ":C" & Rows.Count).Clear
 ActiveSheet.Range("$D$1:$D$" & lig_fin).FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(C[-2],RC[-1]))"
 Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Nekoty

Nekoty

XLDnaute Junior
Re : Aide pour simplification macro

Pierrejean,
votre code fonctionne très bien, merci. je dois revoir la formule de comptabilité pour quelle prenne en compte ce changement.

Merci beaucoup pour votre aide, je n'aurais pas trouvé.

Cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
309
robpellan52
R
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
392
gwenn49
G
O
  • Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
489
olivier388
O
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
344
Usine à gaz
Usine à gaz
Usine à gaz
  • Résolu(e)
XL 2021 Coller "RdV Fait Facturé" de "J" ligne active jusqu'à "J" dernière ligne NON vide
2
Réponses
27
Affichages
682
TooFatBoy
TooFatBoy
F
  • Résolu(e)
XL 2021 Réaliser une macro pour copier une ligne avec formule ?
Réponses
4
Affichages
409
fanou06
F
F
  • Résolu(e)
Microsoft 365 Message Box oui/non
Réponses
2
Affichages
151
Francky79
F
M
  • Résolu(e)
XL 2016 Filtre auto VBA
Réponses
3
Affichages
607
MickaeL_D
M
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
145
marie3107
M

Membres actuellement en ligne

17 membres et 104 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 496
Messages
2 088 980
Membres
103 997
dernier inscrit
SET2A