Modifier plusieurs fichiers excel(2010) au sein d'un unique répertoire via Macro

DDD

XLDnaute Nouveau
Bonjour !
Ayant cherché un sujet similaire sur plusieurs forums, j'ai pu avancer quelque peu sur un blocage que je rencontre actuellement.
Voici les différentes démarches pour exemple :
1 - chaque semaine, je vais dans une base de données pour extraire différents fichiers excel (exemple de fichier en PJ : "fichier X" onglet : Liste extraction)
2 - Ces fichiers sont ensuite sauvegardés dans un répertoire (ex : appelé C:\toto)
3 - Je les retravaille manuellement afin de : supprimer les lignes 1 à 12, supprimer les colonnes D à G, et supprimer la case "merci" et signature de Mr. X" afin d'avoir le fichier en onglet " liste souhaitée"

Après plusieurs recherches, je dispose d'un fichier excel dans lequel j'ai introduis une macro (en PJ "classeur 1") afin d'aller automatiquement dans le répertoire susnommé (toto), ouvrir l'ensemble des fichiers excel étant à l'intérieur, afin que sur chaque fichier, soit effectuées les différentes opérations mentionnées au point 3.).

Le répertoire est bien identifié (lorsque je mets le vrai nom de répertoire), la macro va ouvrir les fichiers, les sauvegarde, et les ferme, comme souhaité. Alors que je pensais ajouter un simple code : "pour cellule C de chaque ligne, si cellule C est vide, supprimer la ligne" et supprimer les colonnes D à G ; impossible de rajouter les opérations que je souhaite effectuer en plus, dans le code présent.. qui ne les prend pas en complete..

Si l'un d'entre vous saurait m'aiguiller... Je suis preneur !
 

Fichiers joints

Staple1600

XLDnaute Barbatruc
Bonsoir

Je te laisse faire les tests et adaptions en te basant sur l'exemple et mes commentaires
VB:
Private Sub CommandButton4_Click()
'Déclaration des variables
Dim myPath As String, myFile As String
 
'Ici, je place mon répertoire
myPath = "C:\toto"
 
'Permet de récupérer le nom des fichiers du répertoire
myFile = Dir(myPath & "\*.*")
 
'Boucle sur l'ensemble des fichiers du répertoire
Do While myFile <> ""
    'On appelle la fonction "ClasseurOuvert" définie plus bas : elle permet de vérifier si le classeur est ouvert du répertoire. Sinon, cette fonction ouvre le classeur.
    Call ClasseurOuvert(myPath & "\" & myFile)
 
    'Avec le classeur ouvert ou qu'on vient d'ouvrir...
    With Workbooks(myFile)
    'juste pour test
    MsgBox .FullName
   MsgBox .Sheets(1).Range("C1:C10").Address
 'intégrer mes commandes : ce que je n'arrive pas à faire !!!
 'donc normalement il faudrait écrire tes commandes en identifiant au préalable la feuille concernée
 'et la plage de cellules concernée
 '.Sheets(1).Range(...
    ActiveWorkbook.Save    'enregistrer les modifications
    ActiveWorkbook.Close  'Fermer
    End With
    'Et on passe au suivant
    myFile = Dir()
Loop
End Sub
 

DDD

XLDnaute Nouveau
Bonsoir

Je te laisse faire les tests et adaptions en te basant sur l'exemple et mes commentaires
VB:
Private Sub CommandButton4_Click()
'Déclaration des variables
Dim myPath As String, myFile As String

'Ici, je place mon répertoire
myPath = "C:\toto"

'Permet de récupérer le nom des fichiers du répertoire
myFile = Dir(myPath & "\*.*")

'Boucle sur l'ensemble des fichiers du répertoire
Do While myFile <> ""
    'On appelle la fonction "ClasseurOuvert" définie plus bas : elle permet de vérifier si le classeur est ouvert du répertoire. Sinon, cette fonction ouvre le classeur.
    Call ClasseurOuvert(myPath & "\" & myFile)

    'Avec le classeur ouvert ou qu'on vient d'ouvrir...
    With Workbooks(myFile)
    'juste pour test
    MsgBox .FullName
   MsgBox .Sheets(1).Range("C1:C10").Address
'intégrer mes commandes : ce que je n'arrive pas à faire !!!
'donc normalement il faudrait écrire tes commandes en identifiant au préalable la feuille concernée
'et la plage de cellules concernée
'.Sheets(1).Range(...
    ActiveWorkbook.Save    'enregistrer les modifications
    ActiveWorkbook.Close  'Fermer
    End With
    'Et on passe au suivant
    myFile = Dir()
Loop
End Sub
Bonsoir ! Cela fonctionne et me fait bien apparaître une fenêtre (msgbox) avec C1C10.
Le problème viendrait donc de l'identification de la feuille concernée ?
 

Staple1600

XLDnaute Barbatruc
Re

Un petit bonus pour continuer à t'aiguiller sur une voie
(ici l'utilisateur choisit le répertoire)
VB:
Sub Test_OK()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
  On Error Resume Next
  '(suppression des vides en colonne C sur la feuille 1)
       .Sheets(1).Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       .Close savechanges:=True
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
 
  • J'aime
Reactions: DDD

DDD

XLDnaute Nouveau
Re

Un petit bonus pour continuer à t'aiguiller sur une voie
(ici l'utilisateur choisit le répertoire)
VB:
Sub Test_OK()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
  On Error Resume Next
  '(suppression des vides en colonne C sur la feuille 1)
       .Sheets(1).Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       .Close savechanges:=True
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
En effet, c'est encore mieux et me permet d'appliquer la macro dès lors que je créé un nouveau répertoire...
J'ai simplement ajouté la ligne suite après celle ci :
.Sheets(1).Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Sheets(1).Columns("D:G").Delete Shift:=xlToLeft
afin de supprimer les colonnes D à G, cela semble fonctionner.
Concernant "merci" ainsi que "signature" il s'agit simplement de sélectionner les cellules contenant ce mot et les supprimer, cela ne me semble pas très compliqué. Par contre, il ne me resterai qu'une petite modification... si je n'abuse pas.. C'est que dans chaque fichier, deux lignes au dessus de la cellule "merci" (colonne A Donc), il faudrait que j'ajoute le mot 'Total', car ma dernière ligne d'extraction reprend le total des calculs (anonymisés).

J'avais déjà utilisé certaines formules avec cell.Value et offset(0.1) ou autre pour me déplacer par rapport à une cellule fixe, mais j'avoue ne pas maîtriser la chose.

Dans tous les cas, merci beaucoup pour ce partage de connaissance !
 

Staple1600

XLDnaute Barbatruc
Re

Concernant "merci" ainsi que "signature" il s'agit simplement de sélectionner les cellules contenant ce mot et les supprimer, cela ne me semble pas très compliqué.
Tu veux effacer le contenu des cellules ou supprimer les cellules (donc les lignes où elles se trouvent) ?

PS: Impossible d'ouvrir ton fichier: Fichier X.xls
 

DDD

XLDnaute Nouveau
Je souhaites supprimer les cellules (et donc les lignes qui y sont rattachées en effet)
ps : je viens de voir en effet qu'il ne fonctionnait pas sur le précédent traitement, je le rechargerai demain de mon ordinateur si besoin est, mais les regles restent identiques dans tous les cas.
 

Staple1600

XLDnaute Barbatruc
Re

Comme je ne peux pas ouvrir ton fichier Fichier X.xls, je ne peux pas faire de tests plus avant ;)
 

DDD

XLDnaute Nouveau
Bonjour Staple,
Grâce à ton code j'ai pu modifier "presque" comme souhaité mon fichier, seulement, à chaque exécution de la macro, cela me créé un second dossier dans le répertoire cible, composé de 4 éléments (filelist.xml / sheet001.htm / stylesshee.css et tabstrip.htm)
Est ce normal ?
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, DDD

Est-ce normal?
Qu'est-ce qui normal en ce vaste monde, hein ? ;)

Mais recentrons nous sur la macro et en premier lieu ton ton dossier.
Quel type de fichiers contient ce dossier?
Uniquement des classeurs Excel (avec les extensions suivantes: xls ou xlsx ou xlsm ou xlsb) ?
 

DDD

XLDnaute Nouveau
Bonsoir le fil, DDD

Est-ce normal?
Qu'est-ce qui normal en ce vaste monde, hein ? ;)

Mais recentrons nous sur la macro et en premier lieu ton ton dossier.
Quel type de fichiers contient ce dossier?
Uniquement des classeurs Excel (avec les extensions suivantes: xls ou xlsx ou xlsm ou xlsb) ?
Ce n'est pas à moi de me prononcer sur cette vaste question :)

Concernant mon mon dossier, il ne s'agit uniquement que de "xls". A force de parcourir quelques indicateurs, j'ai pu trouver cette formule :
Code:
Sub ConvertToCSV()

Dim myPath As String

Dim myString As Variant

    Application.DisplayAlerts = False

'Open Workbook

    With Application.FileDialog(msoFileDialogOpen)



        .AllowMultiSelect = False

        .Show

        myPath = .SelectedItems(1)

    End With

'Open Workbook

    Workbooks.Open Filename:=myPath

'Remove Excel Extension from String

    myExtension = "." & CreateObject("Scripting.FileSystemObject").GetExtensionName(myPath)

    myPath = Left(myPath, Len(myPath) - Len(myExtension))

'Save as CVS

    ActiveWorkbook.SaveAs Filename:=myPath & ".csv", FileFormat:=xlCSV, CreateBackup:=False, Local:=True


'Close Window

    ActiveWindow.Close

'Turn on Alerts

    Application.DisplayAlerts = True


End Sub
[/CODE]

Cette macro fonctionne sur un dossier lamba ne contenant aucune autre consigne, mais je n'arrive pas à "l'incorporer" dans ce que tu m'avais transmis..
 

Staple1600

XLDnaute Barbatruc
Re

1 - chaque semaine, je vais dans une base de données pour extraire différents fichiers excel(exemple de fichier en PJ : "fichier X" onglet : Liste extraction)
Un fichier CSV ce n'est pas à proprement parler un fichier Excel ;)

Tu veux ouvrir tes fichier Excel pour les convertir en *.csv?

Dans ce cas, on s'éloigne de :
3 - Je les retravaille manuellement afin de : supprimer les lignes 1 à 12, supprimer les colonnes D à G, et supprimer la case "merci" et signature de Mr. X" afin d'avoir le fichier en onglet " liste souhaitée"
 

DDD

XLDnaute Nouveau
Re


Un fichier CSV ce n'est pas à proprement parler un fichier Excel ;)
C'est à dire ?

Tu veux ouvrir tes fichier Excel pour les convertir en *.csv?
Dans ce cas, on s'éloigne de :
Alors pas exactement !
En fait, je "souhaiterai" dans la mesure du possible :
- réaliser l'ensemble des opérations mentionnées (ligne 1 à 12, remplacer . par 0, colonnes D à G, etc, et
- et en sauvegardant mon fichier (et passer au suivant), le "convertir" en CSV
 

DDD

XLDnaute Nouveau
Ps : Mais je pourrais très bien aussi effectuer toutes les opérations que je souhaite, sauvegarder en xls, et créer un second bouton de commande, avec la macro que j'ai mentionné précédemment.. Le problème est qu'elle fonctionne par choix de fichier, et non de dossier/répertoire, comme celle que tu m'a proposé. Et c'est là où je n'arrive plus à l'incorporer... (j'espère ne pas me perdre dans mes explications)
 

Staple1600

XLDnaute Barbatruc
Re

Macro modifiée (et testée avec ton fichier Fichie X.xls)
VB:
Sub Test_OK_II()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
 On Error Resume Next
  '-> suppression des lignes 1 à 12
      .Sheets(1).Range("1:12,34:37").EntireRow.Delete
      .Sheets(1).Columns("D:G").Delete Shift:=xlToLeft
      .Sheets(1).[A1].CurrentRegion.Replace What:=".", Replacement:="0", LookAt:=2
      .Sheets(1).Cells(Rows.Count, 2).End(3).Offset(, -1) = "TOTAL"
       'conversion en fichier CSV
       .SaveAs MyPath & VBA.Left(.Name, InStr(.Name, ".") - 1), FileFormat:=xlCSV, Local:=True
       .Close savechanges:=False
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
Je te laisse tester et me redire le résultat.

NB: Sur mon PC, c'est OK, j'obtiens bien des fichiers CSV respectant le modèle.
 
  • J'aime
Reactions: DDD

DDD

XLDnaute Nouveau
Re

Macro modifiée (et testée avec ton fichier Fichie X.xls)
VB:
Sub Test_OK_II()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
On Error Resume Next
  '-> suppression des lignes 1 à 12
      .Sheets(1).Range("1:12,34:37").EntireRow.Delete
      .Sheets(1).Columns("D:G").Delete Shift:=xlToLeft
      .Sheets(1).[A1].CurrentRegion.Replace What:=".", Replacement:="0", LookAt:=2
      .Sheets(1).Cells(Rows.Count, 2).End(3).Offset(, -1) = "TOTAL"
       'conversion en fichier CSV
       .SaveAs MyPath & VBA.Left(.Name, InStr(.Name, ".") - 1), FileFormat:=xlCSV, Local:=True
       .Close savechanges:=False
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
Je te laisse tester et me redire le résultat.

NB: Sur mon PC, c'est OK, j'obtiens bien des fichiers CSV respectant le modèle.
Cela me semble pas mal :) Merci beaucoup !
J'ai simplement modifié la formule : "
Sheets(1).Range("1:12,34:37").EntireRow.Delete"en enlevant 34:37 et en supprimant plutôt l'ensemble des lignes ne contenant aucune valeur en colonne C (plutôt que de supprimer les lignes 34 et 37, car celles-ci varient par contre, en fonction des données de l'extraction (c'est la seule variable, qui est donc solutionnée par cette formule, puisque tant que la colonne C contient une valeur, c'est ok pour moi)

Et j'ai tenté d'insérer le "TOTAL" car par contre, ta version ne fonctionne pas pour moi. Mais mon idée de formule n'a pas l'air de fonctionner malheureusement...

VB:
Private Sub CommandButton1_Click()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
On Error Resume Next
  '-> suppression des lignes 1 à 12
      .Sheets(1).Range("1:12").EntireRow.Delete

' idée de formule pour insérer le total, deux lignes au dessus de la cellule "extraction" qui n'est pas toujours en ligne 35
      .Sheets(1).Cells.Find("Extraction", , xlValues, xlPart).Activate
      .Sheets(1).Cells.Offset(-2, 0) = "TOTAL"

'ligne que j'ai remplacé pour contourner la variable de ligne 34 à 37
     .Sheets(1).Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      .Sheets(1).Columns("D:G").Delete Shift:=xlToLeft
      .Sheets(1).[A1].CurrentRegion.Replace What:=".", Replacement:="0", LookAt:=2
       'conversion en fichier CSV
       .SaveAs MyPath & VBA.Left(.Name, InStr(.Name, ".") - 1), FileFormat:=xlCSV, Local:=True
       .Close savechanges:=False
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
 

Staple1600

XLDnaute Barbatruc
Re,

La précédente macro insérait déjà TOTAL
(je le sais, j'ai testé avant de te proposer le code... :rolleyes:)
Celle-ci le fait également, et tu sais donc pourquoi je peux me permettre d'ici la publier ;)
VB:
Sub Test_OK_IV()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Do While Len(MyFile) > 0
Application.DisplayAlerts = False
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
 On Error Resume Next
  '-> suppression des lignes 1 à 12
      .Sheets(1).Rows("1:12").Delete
      .Sheets(1).Columns("D:G").Delete Shift:=xlToLeft
      .Sheets(1).[A1].CurrentRegion.Replace What:=".", Replacement:="0", LookAt:=2
      With .Sheets(1).Cells(Rows.Count, 2).End(3)
        .Offset(, -1) = "TOTAL": .Offset(2, -1).Resize(3).Clear
       End With
       'conversion en fichier CSV
       .SaveAs MyPath & VBA.Left(.Name, InStr(.Name, ".") - 1), FileFormat:=xlCSV, Local:=True
       .Close savechanges:=False
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
NB: Bien entendu, elles fonctionnent si l'onglet est rigoureusement identique à celui nommé dans ton classeur Tableau extrait
 
  • J'aime
Reactions: DDD

DDD

XLDnaute Nouveau
J'ai dû opérer une mauvaise manipulation hier (comment ? aucune idée...) En tout cas tout fonctionne P A R F A I T E M E N T, je te remercie infiniment.
Par contre, ultime question, nous sommes d'accords qu'avec ce code (celui du début) :
VB:
Sub Test_OK()
Dim FolderName$, MyPath, wkbSource As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Boucle sur l'ensemble des fichiers du répertoire
MyFile = Dir(MyPath & "*.xl?")
Application.DisplayAlerts = False
Do While Len(MyFile) > 0
  Set wkbSource = Workbooks.Open(MyPath & MyFile)
  'Avec le classeur ouvert ou qu'on vient d'ouvrir...
  With wkbSource
  On Error Resume Next
  'j'ajoute n'importe quel macro ?
  End With
  Set wkbSource = Nothing
  'Et on passe au suivant
  MyFile = Dir()
Loop
End Sub
Je peux "potentiellement" y ajouter n'importe quelle macro ? Dès lors que j'identifie bien le classeur ou la feuille concernée ?
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, DDD

DDD
Je peux "potentiellement" y ajouter n'importe quelle macro ? Dès lors que j'identifie bien le classeur ou la feuille concernée ?
Pour paraphraser, Yoda ;)
"Le meilleur des maîtres, l'échec être"
Donc, jeune padawan
Ajoutes ce que tu veux et teste
Ajoutes encore ce que tu veux et teste
Modifies ce que tu as ajouté et teste
Modifies ce que tu as modifié et teste

Bref, suis ton intuition et testes à donf ;)

Et si jamais, ça coince (après avoir grillé -sans succès - quelques neurones pour comprendre pourquoi ), reviens sur XLD pour qu'on te file un coup de main.

PS: Une tite pensée pour Chewie
 
  • J'aime
Reactions: DDD

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas