rendre une macro plus rapide

[michel.dupont]

BONJOUR
Y-a-t il moyen de rendre l'exécution de la macro ci-dessus plus rapide
grand merci de votre aide
MICHEL

Sub copyact()

For Each cell In Selection
Selection.Copy
Sheets("IMPR").Select
ActiveWindow.SmallScroll Down:=-9
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=0
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next
Range("L1").Select
End Sub

 

[Papou-net]

Re : rendre une macro plus rapide

Bonsoir michel.dupont,

Oui, bien sûr qu'il y a moyen d'accélérer cette macro.

A commencer par ajouter 2 lignes pour désactiver et réactiver le rafraîchissement d'écran.

Application.ScreenUpdating = False
Application.ScreenUpdating = True

D'autre part, en supprimant la sélection de cellules pour les opérations de Copier-Coller. Mais, dans l'état actuel, je ne comprends pas pourquoi tu crées une boucle au sein de la sélection alors qu'à chaque passage tu copies cette sélection. Une copie de ton fichier eût été préférable afin de mieux comprendre ce code et de te proposer une version plus précise.

A +

cordialement.

 

[Paf]

Re : rendre une macro plus rapide

Bonjour à tous

s'il s'agit de copier valeurs et format d'une selection, a priori le code suivant réalise la même chose sans boucle (inutile?)

Sub copyact()
 Selection.Copy
 Worksheets("IMPR").Range("B1").PasteSpecial Paste:=xlPasteValues
 Worksheets("IMPR").Range("B1").PasteSpecial Paste:=xlPasteFormats
 
 Range("L1").Select

End Sub

A+

 

[michel.dupont]

Re : rendre une macro plus rapide

Bonjour et déjà merci pour votre aide ...mon problème initial est résolu grâce à vous
en fait mon problème est plus vaste et concerne l'utilisation dans une macro de "each cell in selection" que j'utilise et qui est lente à l'exécution
ainsi dans mon fichier joint je dois transposer des codes (ex AF ce qui veut dire absent en famille) en logos compréhensible pour des personnes handicapées mentales...
la macro en question s exécute par le bouton " transposer les lignes 34 à 53" la selection des colonnes variant en fonction de la période...le but étant de transformer les codes en logos dans un tableau situé en dessous...
j'espère que je me suis bien fait comprendre...
merci
Michel

 

[Paf]

Re : rendre une macro plus rapide

Re,

Pas sûr d'avoir compris et avant de commencer mieux vaut comprendre

s'agit_il de copier (transposer a un autre sens en vocabulaire Excel) en traduisant la plage B2:BV25 de la feuille test dans la plage B30:BV53 de la feuille test en conservant la couleur des colonnes ?

Faudrait-il également les copier en feuille IMPR?

Dans l'attente .. je démarre

A+

 

[Paf]

Re : rendre une macro plus rapide

Re

un code rapide qui copie et "traduit" finalement la plage B34:BV53 dans la plage B61:BV80, si j'ai mieux compris:

Sub copier2()
 Dim i As Integer, j As Integer, MonTab, ListCode As Range

 Set MonDico = CreateObject("Scripting.Dictionary")

 'chargement des codes en dictionary
 With Worksheets("code")
 Set ListCode = .Range("Code")
 For i = 2 To ListCode.Rows.Count + 1
    MonDico(.Cells(i, 1).Value) = .Cells(i, 3)
 Next
 End With

 'mise des données à copier en tableau
 MonTab = Range("B34:BV53")

 ' "traduction" des données
 For i = LBound(MonTab, 1) To UBound(MonTab, 1)
    For j = LBound(MonTab, 2) To UBound(MonTab, 2)
        If MonTab(i, j) <> "" And MonTab(i, j) <> "WE" Then
            MonTab(i, j) = MonDico(MonTab(i, j))
        Else
            MonTab(i, j) = ""
        End If
    Next
 Next
 'copie du tableau traduit
 Range("B61").Resize(UBound(MonTab, 1), UBound(MonTab, 2)) = MonTab

End Sub

Seul problème les symboles sont de couleur noire, et il faut utiliser la Mise en forme Conditionnelle sur la plage B61:BV80 pour retrouver les bonnes couleurs rouges et verts. Jusque là pas de soucis sauf pour les symboles sur 2 caractères ( comme "4@" ) qui posent soucis.

Je regarde

A+

 

[Paf]

Re : rendre une macro plus rapide

Re

avec un code basé sur le même principe que la traduction, pour la mise en forme, mais qui ne copie plus la plage entière, uniquement la selection.
Mais qui nécessite l'insertion en feuille "code" d'une colonne D contenant les codes couleur (Noir=1;Rouge=3;Vert=43 et pour Foyer Médical :4 pour indiquer changement de police(Wingdings 2) et couleur rouge). Le décalage ne nuit pas car les plages nommées sont décalées automatiquement.

Sub copier2()

'Nécessite l'insertion en feuille "code" d'une colonne D contenant les codes couleur (Noir=1;Rouge=3;Vert=43
       'et pour Foyer Médical 4 pour indiquer changement de police(Wingdings 2) et couleur rouge
 Dim i As Integer, j As Integer, MonTab, ListCode As Range, MaCol
 Dim Plage As Range, Cel
 Set MonDico = CreateObject("Scripting.Dictionary")

 'chargement des codes en dictionary
 With Worksheets("code")
 Set ListCode = .Range("Code")
 For i = 2 To 12
    MonDico(.Cells(i, 1).Value) = .Cells(i, 3)
 Next
 End With

 'mise des données à copier en tableau
 MonTab = Selection

 ' "traduction" des données
 For i = LBound(MonTab, 1) To UBound(MonTab, 1)
    For j = LBound(MonTab, 2) To UBound(MonTab, 2)
        If MonTab(i, j) <> "" And MonTab(i, j) <> "WE" Then
            MonTab(i, j) = MonDico(MonTab(i, j))
        Else
            MonTab(i, j) = ""
        End If
    Next
 Next
 'copie du tableau traduit
 MaCol = Selection.Column
 Cells(61, MaCol).Resize(UBound(MonTab, 1), UBound(MonTab, 2)) = MonTab

 '******************* Mise en forme *******************
 'chargement des symboles et couleurs associées en dictionary
 With Worksheets("code")
 For i = 2 To 12
    MonDico(.Cells(i, 3).Value) = .Cells(i, 4)
 Next
 End With

 'définition de la plage à traiter
 Set Plage = Range("B61:BV80")

 ' mise en couleur des symboles
 For Each Cel In Plage
    If Cel.Value <> "" And Cel.Value <> "WE" Then
        If MonDico(Cel.Value) = 4 Then
            Cel.Font.Name = "Wingdings 2"
            Cel.Font.ColorIndex = 3
        Else
            Cel.Font.Name = "Webdings"
            Cel.Font.ColorIndex = MonDico(Cel.Value)
        End If
    End If
 Next

End Sub

A+

 

[michel.dupont]

Re : rendre une macro plus rapide

Merci...je suis vraiment un néophyte...la macro me renvoie un code d'erreur...peux-tu y jeter un oeil si ce n'est pas trop de demander...
désolé de te faire travailler!
Michel
ps:je te renvoie le fichier

 

[Paf]

Re : rendre une macro plus rapide

Re,

au post #7 je précisais qu'il fallait insérer les codes couleurs mais assez précisément. pour chaque ligne il faut préciser le code couleur.
Voir PJ

Attention en insérant les colonnes les références de la plage nommée Repas n'ont pas été mise à jour. A corriger manuellement

A+

 

[michel.dupont]

Re : rendre une macro plus rapide

bONJOUR PAF
Toujours la même erreur...désolé
voir image attachée
merciM
Michel

 

[Paf]

Re : rendre une macro plus rapide

Re,

au post #7:

un code .....mais qui ne copie plus la plage entière, uniquement la selection.

j'étais revenu à ce qui se faisait avant (a priori) a savoir sélectionner une plage puis la copier.
S'il n'y a qu'une seule cellule en sélection, ça ne marche effectivement pas. je regarde,

A moins que vous ne préfériez copier la plage entière?

+

 

[michel.dupont]

Re : rendre une macro plus rapide

Bonjour
oui la page entière c'est mieux...mais c'est déjà une grande avancée pour moi et je vous en remercie vivement...
Michel

 

[Paf]

Re : rendre une macro plus rapide

Re

La page entière ?

Précisez la plage de données à copier/traduire (a priori B34:BV53) ainsi que les données à copier (WE..)

Si c'est bien la plage B34:BV53, dans le dernier code

remplacer

'mise des données à copier en tableau
 MonTab = Selection

par

 'mise des données à copier en tableau
 MonTab = Range("B34:BV53")

A+

 

[michel.dupont]

Re : rendre une macro plus rapide

merci tardif et sincère
amicalement
Michel