Macro Visual Basic (VBA), rechercheV et correction
eriiic Messages postés 24581 Date d'inscription Statut Contributeur Dernière intervention -
Bonjour,
J'ai une modification à effectuer sur à peu près 1000 fichiers Excel (à la volée sans les ouvrir) dont les extensions varient entre .xls et .xlsx. Cette modification doit s'opérer uniquement sur la feuille nommée "Dossier" et consiste à remplacer le texte de la cellule à droite de celle nommée "Documents clients" par le texte "N/A".
Jusque là, ça va à peu près... Ma difficulté est bien évidemment que cette paire de cellules n'est jamais positionnée au même endroit selon les fichiers et que les extensions de fichiers diffèrent entre du xls et du xlsx... Je dois donc faire appel à une fonction rechercheV ou équivalent sous Visual Basic. Et là, je décroche !
Voici ma ligne de code que j'ai écrite mais qui fonctionne uniquement si la cellule à modifier est toujours située au même endroit (en F15) dans un fichier .xls uniquement
Option Explicit
Sub test()
Dim r As String, f As String, wb As Workbook
r = ThisWorkbook.Path & "\ici\"
f = Dir(r & "*.xlsx")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(r & f)
wb.Worksheets("Dossier").Range("f15").Value = "hello"
ActiveWorkbook.Save
wb.Close False
End If
f = Dir
Loop
End Sub
J'ai déposé mes fichiers au lien suivant qui contient :
- La macro sous Excel nommée Macro_changement masse excel.xlsm
- Un dossier nommé "ici" avec 5 fichiers exemples contenant les 2 cellules citées au dessus
- Une macro supplémentaire pour imprimer en masse nommée Macro_Impression multi fichiers d'une feuille.xlsm
https://drive.google.com/drive/folders/1z8w14_2l8jtD9O07fR2Lmb8FfENmn0LL?usp=sharing
Je recherche désespérément la solution mais sans succès. Appel aux génies car je ne suis pas Black Belt en VBA !
Merci d'avance,
5 réponses
-
Bonjour,
je ne fais que la partie remplacement car on ne peut boucler sur les fichiers de ton cloud
Sub test() Dim r As String, f As String, wb As Workbook Dim c As Range, erreur(1 To 1000, 1 To 1), nbErr As Long Set wb = Workbooks("dhj.xls.xlsx") 'remplacer par l'ouverture d'un fichier With wb.Worksheets("Dossier") Set c = .Cells.Find("Documents clients", , xlValues, xlWhole) If Not c Is Nothing Then c.Offset(, 1) = "N/A" Else nbErr = nbErr + 1 erreur(nbErr, 1) = wb.Name End If End With ' If nbErr > 0 Then [C2].Resize(1000) = erreur ' ecriture erreurs, choisir feuille et colonne ' ActiveWorkbook.Save ' wb.Close False End Subet tu devrais remplacer f = Dir(r & "*.xlsx") par f = Dir(r & "*.xls*")
eric
-
Il faut l'intégrer à ton code qui ouvre les fichiers du répertoire.
Tu vois que le nom du fichier que j'ai utilisé pour les tests est écrit en dur
-
Ca y est ça fonctionne. Je l'avais intégré mais pas dans les règles de l'art. Un grand merci à toi Eric.
Pour ceux qui souhaite s'inspirer de cette macro la voici...
Option Explicit
Sub test()
Dim r As String, f As String, wb As Workbook
Dim c As Range, erreur(1 To 1000, 1 To 1), nbErr As Long
r = ThisWorkbook.Path & "\ici\"
f = Dir(r & "*.xls") 'Remplacer par l'extension ".xls" par ".xlsx" si nécessaire
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(r & f)
With wb.Worksheets("Dossier")
Set c = .Cells.Find("Documents clients", , xlValues, xlWhole)
If Not c Is Nothing Then
c.Offset(, 1) = "N/A"
Else
nbErr = nbErr + 1
erreur(nbErr, 1) = wb.Name
End If
End With
ActiveWorkbook.Save
wb.Close False
End If
f = Dir
Loop
End Sub
-
-
Je souhaiterai faire maintenant la même chose avec un logo positionné sur toutes les feuilles des 1000 fichiers Excel. Je souhaiterai changer ce logo (image) par un nouveau (image).
Est-ce possible ?
-
Bonjour,
je t'avais d'essayer avec :
Dir(r & "*.xls*")
avec une * pour traiter *.xls et *.xlsm
Pour ta nouvelle question tu dois démarrer un nouveau topic avec plus de détails.
Et déposer un fichier de travail sur cjoint.com et coller le lien fourni dans ton post.
eric
-
Bonjour Eric, bon ma macro fonctionne parfaitement et je te remercie de ton aide. Cependant, je souhaiterai l'améliorer car bien évidemment, je viens de m'apercevoir de quelque problème à son exécution :
1/ la feuille Excel que j'appelle dans cette macro n'a pas toujours le même nom. Parfois, elle s'appelle "Dossier", parfois "Dossier " (avec un espace après le r) et parfois même " Dossier" (avec un espace avant le D). Du coup, j'ai un message d'erreur lorsque j'exécute la macro. Comment faire en sorte qu'elle fonctionne qu'elle que soit la syntaxe de la feuille ?
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(r & f)
With wb.Worksheets("Dossier")
Set c = .Cells.Find("Documents clients", , xlValues, xlWhole)2/ Je souhaiterai que la macro s'exécute dans des fichier contenus dans des sous-dossier au dossier "ici".
Sub test()
Dim r As String, f As String, wb As Workbook
Dim c As Range, erreur(1 To 1000, 1 To 1), nbErr As Long
r = ThisWorkbook.Path & "\ici\"
f = Dir(r & "*.xls") 'Remplacer par l'extension ".xls" par ".xlsx" si nécessaireLe plus important serait de résoudre le 1/ car pour le 2/ j'ai une solution (un peu chiante) qui consiste à extraire chaque fichier de son dossier en les plaçant la racine.
cdlt,
Jérôme
-
-
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question -
Bonjour,
ce qu'il faut c'est agir à la source et ne pas accepter de telles erreurs.
Si tu refuses leur fichier en leur demandant de refaire correctement ils apprendront vite.
Renommer les feuilles le temps qu'ils comprennent :
Dim sh As Worksheet For Each sh In wb.Worksheets sh.Name = Trim(sh.Name) ' supprime les espaces début et fin de chaine ' sh.Name = Application.Trim(sh.Name) ' supprime aussi les espaces multiples entre mots pour n'en laisser q'un Next shà toi de voir si tu sauvegarde le fichier corrigé...
Pour le 2) tu trouveras sans difficulté sur google des exemples de balayage des sous-dossiers
eric
