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!!
Salut le forum
Gigi déjà juste le code de ta macro de conversion devrait suffir.
Mytå
Salut Mytå
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...
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...
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
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
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