Probleme un macro sur excel
kayankaiu
-
michel_m Messages postés 18903 Date d'inscription Statut Contributeur Dernière intervention -
michel_m Messages postés 18903 Date d'inscription Statut Contributeur Dernière intervention -
Bonjour,
salut mes amis
voila j'ai un macro qui permet d'échanger un seule mot (qui se répète dans la même colonnes sur plusieurs classeur).
j ai essaye mais ca marche pas il me demande le répertoire mais lorsque j exécute ça ne change rien automatiquement sur tous les classeurs que j ai sur ce répertoire voila le code et si quelque 'un a une réponse n hésitez pas
merci pour vos réponses
Sub ModifierLibelle()
'déclaration des variables
Dim oShell As Object, strFileName As Object
Dim oFolder As Object
Dim oFolderItem As Object
Dim OldLibelle As String, NewLibelle As String, NomClasseur As String
Dim Trouve As Range
'empêche le rafraichissement de l'écran pour gagner en rapidité
Application.ScreenUpdating = False
'remplissage des variables :
'NomClasseur = comme son nom l'indique... le nom de ce classeur
'OldLibelle = comme son nom l'indique, l'ancien libellé (à remplacer)
'NewLibelle = comme son nom l'indique... le nouveau libellé
NomClasseur = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
'on a inscrit l'ancien libellé en D5
OldLibelle = Sheets(1).Range("D5").Value
'on a inscrit le nouveau libellé en D6
NewLibelle = Sheets(1).Range("D6").Value
'test si les libellés (ancien et nouveau) sont bien remplis
If OldLibelle = "" Or NewLibelle = "" Then
'sinon, message à l'utilisateur
MsgBox "Saisie obligatoire en D5 et D6"
'et on ne fait plus rien, on sort de la procédure
Exit Sub
End If
'Ici, partie technique consistant à ouvrir une fenêtre
Set oShell = CreateObject("Shell.Application")
'permettant le choix du répertoire ou se situent les fichiers excel
Set oFolder = oShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "c:\")
'en cas d'annulation par l'utilisateur
If oFolder Is Nothing Then
'message d'abandon
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
'boucle sur tous les fichiers du répertoire
'ne tiens pas compte de l'extension donc sur TOUS les fichiers
For Each strFileName In oFolder.Items
'test si :
'1- le fichier est bien un fichier Excel
'oFolder.GetDetailsOf(strFileName, 2) = "Feuille de calcul Microsoft Excel"
'2- le fichier n'est pas celui qui contient la macro (le mien, ce classeur ci)
'And strFileName <> NomClasseur
If oFolder.GetDetailsOf(strFileName, 2) = "Feuille de calcul Microsoft Excel" And strFileName <> NomClasseur Then
'si c'est tout bon, on ouvre le classeur
Workbooks.Open oFolder.ParentFolder.ParseName(oFolder.Title).Path & "\" & strFileName
'début du bloc "dans le classeur qu'on vient d'ouvrir"
With Workbooks(strFileName & ".xls")
'bloc dans la feuille active (en même temps, il n'y a qu'une feuille par classeur...)
With ActiveSheet
'on cherche dans toutes les cellules l'ancien libellé
Set Trouve = .Cells.Find(OldLibelle)
's'il ne s'y trouve pas on fait rien
If Trouve Is Nothing Then
Else
's'il s'y trouve on remplace par le nouveau libellé dans la cellule
'(Trouve = cellule ou on l'a trouvé)
Trouve.Value = NewLibelle
End If
Set Trouve = Nothing
'fin du bloc feuille
End With
'on enregistre les modifs
.Save
'on ferme
.Close
'fin du bloc classeur
End With
End If
Next
End If
'on rétablit le rafraichissement d'écran
Application.ScreenUpdating = True
End Sub
salut mes amis
voila j'ai un macro qui permet d'échanger un seule mot (qui se répète dans la même colonnes sur plusieurs classeur).
j ai essaye mais ca marche pas il me demande le répertoire mais lorsque j exécute ça ne change rien automatiquement sur tous les classeurs que j ai sur ce répertoire voila le code et si quelque 'un a une réponse n hésitez pas
merci pour vos réponses
Sub ModifierLibelle()
'déclaration des variables
Dim oShell As Object, strFileName As Object
Dim oFolder As Object
Dim oFolderItem As Object
Dim OldLibelle As String, NewLibelle As String, NomClasseur As String
Dim Trouve As Range
'empêche le rafraichissement de l'écran pour gagner en rapidité
Application.ScreenUpdating = False
'remplissage des variables :
'NomClasseur = comme son nom l'indique... le nom de ce classeur
'OldLibelle = comme son nom l'indique, l'ancien libellé (à remplacer)
'NewLibelle = comme son nom l'indique... le nouveau libellé
NomClasseur = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
'on a inscrit l'ancien libellé en D5
OldLibelle = Sheets(1).Range("D5").Value
'on a inscrit le nouveau libellé en D6
NewLibelle = Sheets(1).Range("D6").Value
'test si les libellés (ancien et nouveau) sont bien remplis
If OldLibelle = "" Or NewLibelle = "" Then
'sinon, message à l'utilisateur
MsgBox "Saisie obligatoire en D5 et D6"
'et on ne fait plus rien, on sort de la procédure
Exit Sub
End If
'Ici, partie technique consistant à ouvrir une fenêtre
Set oShell = CreateObject("Shell.Application")
'permettant le choix du répertoire ou se situent les fichiers excel
Set oFolder = oShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "c:\")
'en cas d'annulation par l'utilisateur
If oFolder Is Nothing Then
'message d'abandon
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
'boucle sur tous les fichiers du répertoire
'ne tiens pas compte de l'extension donc sur TOUS les fichiers
For Each strFileName In oFolder.Items
'test si :
'1- le fichier est bien un fichier Excel
'oFolder.GetDetailsOf(strFileName, 2) = "Feuille de calcul Microsoft Excel"
'2- le fichier n'est pas celui qui contient la macro (le mien, ce classeur ci)
'And strFileName <> NomClasseur
If oFolder.GetDetailsOf(strFileName, 2) = "Feuille de calcul Microsoft Excel" And strFileName <> NomClasseur Then
'si c'est tout bon, on ouvre le classeur
Workbooks.Open oFolder.ParentFolder.ParseName(oFolder.Title).Path & "\" & strFileName
'début du bloc "dans le classeur qu'on vient d'ouvrir"
With Workbooks(strFileName & ".xls")
'bloc dans la feuille active (en même temps, il n'y a qu'une feuille par classeur...)
With ActiveSheet
'on cherche dans toutes les cellules l'ancien libellé
Set Trouve = .Cells.Find(OldLibelle)
's'il ne s'y trouve pas on fait rien
If Trouve Is Nothing Then
Else
's'il s'y trouve on remplace par le nouveau libellé dans la cellule
'(Trouve = cellule ou on l'a trouvé)
Trouve.Value = NewLibelle
End If
Set Trouve = Nothing
'fin du bloc feuille
End With
'on enregistre les modifs
.Save
'on ferme
.Close
'fin du bloc classeur
End With
End If
Next
End If
'on rétablit le rafraichissement d'écran
Application.ScreenUpdating = True
End Sub
A voir également:
- Probleme un macro sur excel
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Liste déroulante excel - Guide
- Word et excel gratuit - Guide
- Comment faire un tri personnalisé sur excel - Guide
- Comment calculer la moyenne sur excel - Guide
1 réponse
Bonjour,
essaies cette macro
détail: il vaut mieux regrouper les sorties de macro comme les erreurs à la fin du code d'où les "goto" bannis hors des gestions d'erreur
à l'avenir pense à mettre tes codes entre les balises <>(onglet en haut du message)
essaies cette macro
détail: il vaut mieux regrouper les sorties de macro comme les erreurs à la fin du code d'où les "goto" bannis hors des gestions d'erreur
à l'avenir pense à mettre tes codes entre les balises <>(onglet en haut du message)
Sub ModifierLibelle()
'déclaration des variables
Dim ObjShell As Object, strFileName As Object
Dim ObjFolder As Object
Dim OldLibelle As String, NewLibelle As String, NomClasseur As String
Dim Chemin As String, Trouve As String
'empêche le rafraichissement de l'écran pour gagner en rapidité
Application.ScreenUpdating = False
'remplissage des variables :
'NomClasseur = comme son nom l'indique... le nom de ce classeur
'OldLibelle = comme son nom l'indique, l'ancien libellé (à remplacer)
'NewLibelle = comme son nom l'indique... le nouveau libellé
NomClasseur = ThisWorkbook.Name
'on a inscrit l'ancien libellé en D5
OldLibelle = Sheets(1).Range("D5").Value
'on a inscrit le nouveau libellé en D6
NewLibelle = Sheets(1).Range("D6").Value
'test si les libellés (ancien et nouveau) sont bien remplis
If OldLibelle = "" Or NewLibelle = "" Then GoTo saisie
'Ici, partie technique consistant à ouvrir une fenêd'images:"
Set ObjShell = CreateObject("Shell.Application")
Set ObjFolder = ObjShell.BrowseForFolder(&H0&, "choisir un dossier", 1)
'Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "c:\") ton classeur
If ObjFolder Is Nothing Then GoTo abandon 'Si on sort sans sélection
Chemin = ObjFolder.ParentFolder.ParseName(ObjFolder.Title).Path & ""
ChDir Chemin
'parcours du dossier
fich = Dir("*.xls")
While fich <> ""
If fich <> NomClasseur Then
Workbooks.Open fich
Trouve = ActiveSheet.Cells.Find(OldLibelle, , xlValues).Address
If Trouve <> "" Then
Range(Trouve) = NewLibelle
With ActiveWorkbook
.Save
.Close
End With
End If
End If
fich = Dir
Wend
Exit Sub
'-----------------Gestion des erreurs
saisie:
MsgBox "Saisie obligatoire en D5 et D6", vbCritical
Exit Sub
abandon:
MsgBox "Abandon opérateur", vbCritical, "Annulation"
End Sub
ça exécute mais il ne remplace pas (il me demande le chemin du dossier )
mais il ne remplace pas le remplacement se fait sur la même colonne dans chaque classeur)
merci une 2eme fois pour la réponse
merci encore de votre aide
Tu es sûr que c'est définitif?
je compte bien sur toi
donc au lieu d ouvrir chaque classeur et changerpar 'rechercher replacer' pour chacune de ces 100 claseurs je veux l automatise pour le faire pour les 100 classeurs.
merci