Raccourcir le timing d'exécution d'une macro

Bonjour le fofo et ceux/celles qui me connaissent!

J'ai un fichier (créé sous excel 2003) pour un jeu sur internet. Ce jeu est une gestion de ferme et ce fichier est une sorte d'"aide" à la gestion des animaux, cultures...

Depuis peu, le site qui héberge le jeu s'est ouvert aux anglophones. Mon fichier étant disponible sur le site, j'ai voulu me mettre à la page moi aussi ^^

Via ce forum, j'ai trouvé quelqu'un qui a bien voulu me donner un coup de main, et m'a créé une macro. Ca marche nickel, mais...Problème : le fichier comporte entre 15 et 20 feuilles (toutes a traduire), du coup, une fois la langue choisie, ca mouline env. 2 minutes avant de rendre la main.

J'aurais eu besoin de conseils (et d'aide!!) pour essayer de raccourcir ce timing, quite a refaire la macro utilisée!

Je ne peux malheureusement pas joindre le fichier ici, car il fait plus de 2Mo, mais je peux l'envoyer à qui le souhaite. Mon adresse : domercq.ghislain@neuf.fr

Merci a vous!!

up!

Salut le forum

Gigi déjà juste le code de ta macro de conversion devrait suffir.

Mytå

10devis-ste-v3-1.xlsm (64.03 Ko)

Salut Mytå et le fofo!

Alors, a priori, j'ai 2 choses :

un code dans "module" :

Sub Macro1()

'

' Macro1 Macro

'

'

ActiveWindow.ScrollColumn = 2

ActiveWindow.ScrollColumn = 4

Range("J1").Select

Selection.End(xlToRight).Select

Range("IV1").Select

Selection.End(xlToLeft).Select

Selection.End(xlToLeft).Select

Selection.End(xlToLeft).Select

Range("B1").Select

ActiveCell.Offset(1, 0).Range("A1").Select

Range("P2").Select

Selection.Copy

Sheets("notice").Select

ActiveCell.Select

ActiveSheet.Paste

Sheets("Textes").Select

ActiveCell.Offset(1, -14).Range("A1").Select

End Sub

et un code sur la feuille 1 de mon fichier :

Private Sub Worksheet_Change(ByVal Target As Range)

' Déclenche le renouvellement de la page

Application.ScreenUpdating = False

' Test de la cellule modifiée

If Target.Address = Range("Language").Address Then

' mémorisation de la feuille active

FeuilleActive = ActiveSheet.Name

' mémorisation de la langue choisie

LangueChoisie = Target.Value

' Déplacement sur la feuille de texte

Sheets("Textes").Select

' Recherche de la colonne contenant les textes dans la langue demandée

ActiveSheet.Range("IV1").Select

Do

Selection.End(xlToLeft).Select

Loop Until ActiveCell.Value = LangueChoisie Or ActiveCell.Column = 1

' Enregistrer le numéro de la colonne

LangueColonne = ActiveCell.Column

' Contrôle si la langue a été trouvée, sinon donner la première colonne par défaut

If LangueColonne = 1 Then

Selection.End(xlToRight).Select

LangueColonne = LangueColonne - ActiveSheet.Column

End If

' déplacement au début des adresses

ActiveSheet.Range("ColonneAdresse").Select

' Calcul de nombre de colonne qu'il faudra se déplacer pour retrouver les textes dans la bonne langue

' à partir de la colonne des adresses.

LangueColonne = LangueColonne - ActiveCell.Column

' Déplacement sur la 1ère adresse

ActiveCell.Offset(1, 0).Select

' Boucle de copie des textes aux adresses spécifiées

Do While ActiveCell.Value <> ""

' Mémorisation de l'adresse de destination

AddDest = ActiveCell.Value

' Déplacement sur le texte de la langue choisie

ActiveCell.Offset(0, LangueColonne).Select

' Copie du texte

Selection.Copy

' Décomposition de l'adresse en nom de feuille et nom de cellule

PosSepar = WorksheetFunction.Search("!", AddDest, 1)

NomFeuille = Left(AddDest, PosSepar - 1)

NomCellule = Right(AddDest, Len(AddDest) - PosSepar)

' Déplacement à l'adresse de destination

Sheets(NomFeuille).Select

' Sélection du nom de destination et recopie du texte

Sheets(NomFeuille).Select

ActiveSheet.Range(NomCellule).Select

ActiveSheet.Paste

Application.CutCopyMode = False

' Retour sur la feuille texte

Sheets("Textes").Select

' Retour sur la colonne adresse,à l'adresse suivante

ActiveCell.Offset(1, -LangueColonne).Select

Loop

' retour sur la 1ere page

Sheets(FeuilleActive).Select

ActiveSheet.Range("Language").Select

' Si la cellule modifiée est différente

Else

' Rien

End If

End Sub

A l'origine, c'était Dan de Pic qui m'avait réalisé cette macro (puisque moi, j'y connais rien... )

up

Bonsoir,

Pourrais-tu expliquer ce que tu cherches à faire avec ta macro 1.

Je ne comprends pas le pourquoi de toutes ces sélections (J1, puis IV1, B1) Toute cela pour copier P2 dans une autre feuille.

Merci de tes explications

Dan

Edition : A la lecture du code de la macro 2, je pense que ta macro ne sert à rien. C'est probablement Dan de Pic qui a enregistré ce code pour construire ta deuxième macro.

edition 2 :

Essaye ceci :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = Range("Language").Address Then
FeuilleActive = ActiveSheet.Name
LangueChoisie = Target.Value
Sheets("Textes").Range("IV1").Select
Do
Selection.End(xlToLeft).Select
Loop Until ActiveCell.Value = LangueChoisie Or ActiveCell.Column = 1
LangueColonne = ActiveCell.Column
If LangueColonne = 1 Then
Selection.End(xlToRight).Select
LangueColonne = LangueColonne - ActiveSheet.Column
End If
ActiveSheet.Range("ColonneAdresse").Select
LangueColonne = LangueColonne - ActiveCell.Column
ActiveCell.Offset(1, 0).Select
With ActiveCell
Do While .Value <> ""
    AddDest = .Value
    .Offset(0, LangueColonne).Copy 'Copie du texte
PosSepar = WorksheetFunction.Search("!", AddDest, 1)
NomFeuille = Left(AddDest, PosSepar - 1)
NomCellule = Right(AddDest, Len(AddDest) - PosSepar)
Sheets(NomFeuille).Range(NomCellule).Paste ' Sélection du nom de destination et recopie du texte
Application.CutCopyMode = False
Sheets("Textes").Select
.Offset(1, -LangueColonne).Select
Loop
End With
Sheets(FeuilleActive).Range("Language").Select
Else

End If
End Sub

A te relire

Dan

merci Nad Dan,

Je viens de remplacer (dans une copie de mon fichier) la macro par la tienne...

Comme j'ai dit : je n'y connais rien en macro... donc je ne peux pas te dire a quoi sert la macro1...

j'ai un problème avec la tienne :

que je laisse ou pas ma macro1, le fichier buggue à cette ligne :

Sheets("Textes").Range("IV1").Select

soit, peu après le début de la macro...

Au plaisir de te relire, toi ou un autre... en tout cas, merci de t'etre penché sur mon problème!

Gigi

Re,

Ok.

Essaye en remplaçant l'instruction par ceci :

with Sheets("Textes")
 .Select 
 .Range("IV1").Select 
End with

A te relire

Dan

Salut le Forum, et salut Nad Dan

Suite à ta réponse, j'ai remplacé la ligne qui buggué par tes 4 lignes.

Maintenant, ca bloque plus loin, vers la fin. (c'est la ligne en rouge ci dessous)

Ci joint la macro "dernier jus" :

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

If Target.Address = Range("Language").Address Then

FeuilleActive = ActiveSheet.Name

LangueChoisie = Target.Value

With Sheets("Textes")

.Select

.Range("IV1").Select

End With

Do

Selection.End(xlToLeft).Select

Loop Until ActiveCell.Value = LangueChoisie Or ActiveCell.Column = 1

LangueColonne = ActiveCell.Column

If LangueColonne = 1 Then

Selection.End(xlToRight).Select

LangueColonne = LangueColonne - ActiveSheet.Column

End If

ActiveSheet.Range("ColonneAdresse").Select

LangueColonne = LangueColonne - ActiveCell.Column

ActiveCell.Offset(1, 0).Select

With ActiveCell

Do While .Value <> ""

AddDest = .Value

.Offset(0, LangueColonne).Copy 'Copie du texte

PosSepar = WorksheetFunction.Search("!", AddDest, 1)

NomFeuille = Left(AddDest, PosSepar - 1)

NomCellule = Right(AddDest, Len(AddDest) - PosSepar)

Sheets(NomFeuille).Range(NomCellule).Paste ' Sélection du nom de destination et recopie du texte

Application.CutCopyMode = False

Sheets("Textes").Select

.Offset(1, -LangueColonne).Select

Loop

End With

Sheets(FeuilleActive).Range("Language").Select

Else

End If

End Sub

Merci à tous pour votre aide!

up

Merci à tou(te)s

personne n'a une idée? je sais que VBA n'est pas connu de tous (moi le premier...) mais je ne désespère pas!

Re bonjour le forum!

voila un extrait de mon fichier :

https://www.excel-pratique.com/~files/doc/excel_pratique.xls

c'est vraiment un extrait, car avec ses 55ko, on est loin des 2.4Mo ^^ du fichier complet.

Le fichier complet comporte 22 onglets mais je suppose que si ca marche pour cet extrait, ca devrait marcher pour le fichier complet... ceci dit, j'y connais toujours pas plus en macro, donc je me plante peut etre! ^^

La macro est légèrement différente par rapport au dernier copier coller de ce topic, et du coup ca buggue un peu plus loin.

Le problème, c'est qua dans le fichier joint, si on choisit "francais", ca tourne en boucle alors que "anglais" et "espagnol" font bugger la macro.

Merci à tout le monde!

Bonjour,

A priori ma macro est lente et buggue pour plusieurs raisons :

  • cellules fusionnées dans la feuille source et les feuilles destinations (fusion identique entre source et destinations), chose qui serait à éviter (mais impossible à supprimer, au vu de la mise en page du fichier)
  • la macro scanne tout le fichier (env. 20 feuilles) d'un seul coup.

Beaucoup trop de choses seraient à reprendre, pour essayer de gagner sur le timing d'une macro qui, finalement, à l'origine, marchait très bien, quoique un peu longue.. a moins que la macro ne soit re travaillable!

Merci a tou(te)s pour les diverses interventions

Gigi

Petite mise à jour de ce topic avec un complément d'informations!!

Petit rappel : J'ai fait un fichier pour aider les joueurs d'un jeu en ligne. Depuis peu, des anglophones nous ont rejoint, donc j'ai demandé de l'aide ici pour développer une "macro traductrice". Le fichier (la macro?) est tel qu'aujourd'hui, une fois la langue choisie, la macro mouline 2 bonnes minutes avant de rendre la main.

Mon fichier est un fichier qui évolue tout les jours ou presque (une nouvelle version du fichier sort toutes les 12-13 semaines). A ce jour, le fichier contient 21 feuilles (à traduire). La macro (voir copier coller ci dessous) rentre dans un onglet "base de données", qui contient 1316 lignes, et les copie/colle une par une dans les cellules concernées.

Aujourd'hui, la macro a été revue, et le timing raccourci (merci Nad-dan) mais d'après lui, il est possible de l'accélérer encore... Si quelqu'un peut lui donner un coup de main voila le dernier jus de la macro :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim FeuilleActive As String, LangueChoisie As String, Nomfeuille As String

Dim AddDest

Dim Languecolonne As Byte, PosSepar As Byte

Dim Nomcellule As String

Application.ScreenUpdating = False

If Target.Address = Range("Language").Address Then

Nomfeuille = ActiveSheet.Name

LangueChoisie = Target.Value

With Sheets("Textes")

.Select

.Range("IV1").Select

End With

Do

Selection.End(xlToLeft).Select

Loop Until ActiveCell.Value = LangueChoisie Or ActiveCell.Column = 1

Languecolonne = ActiveCell.Column

If Languecolonne = 1 Then

Selection.End(xlToRight).Select

Languecolonne = Languecolonne - ActiveSheet.Column

End If

ActiveSheet.Range("ColonneAdresse").Select

Languecolonne = Languecolonne - ActiveCell.Column

ActiveCell.Offset(1, 0).Select

Do While ActiveCell.Value <> ""

With ActiveCell

AddDest = .Value

PosSepar = WorksheetFunction.Search("!", AddDest, 1)

Nomfeuille = Left(AddDest, PosSepar - 1)

Nomcellule = Right(AddDest, Len(AddDest) - PosSepar)

If .Offset(0, Languecolonne).MergeCells Then

.Offset(0, Languecolonne)(1).Select

Selection.Copy

Else

.Offset(0, Languecolonne).Copy

End If

On Error GoTo Erreur

Application.EnableEvents = False

With Sheets(Nomfeuille)

.Select

.Range(Nomcellule).Select

.Paste

End With

Application.EnableEvents = True

Sheets("Textes").Select

If IsEmpty(.Offset(1, 0)) Then Exit Sub

.Offset(1, 0).Select

End With

Loop

With Sheets(Nomfeuille)

.Select

.Range("Language").Activate

End With

Else

End If

Exit Sub

Erreur:

MsgBox "Erreur de procédure"

Application.EnableEvents = True

End Sub

Merci à tou(te)s!!

Cdlt,

Gigi

Rechercher des sujets similaires à "raccourcir timing execution macro"