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

[DDD]

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 !

 

[Staple1600]

Re

Macro modifiée (et testée avec ton fichier Fichie X.xls)

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.

 

[DDD]

Re

Macro modifiée (et testée avec ton fichier Fichie X.xls)

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...

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]

Re,

La précédente macro insérait déjà TOTAL
(je le sais, j'ai testé avant de te proposer le code... )
Celle-ci le fait également, et tu sais donc pourquoi je peux me permettre d'ici la publier

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

 

[DDD]

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) :

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]

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

 

[DDD]

Bonsoir le fil, DDD

DDD

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

Bonsoir Staple,
Pour information, Yoda disait aussi :"Bonnes relations avec les Wookies, j'entretiens ". Je doute pourtant que cela l'ait aidé dans sa vie..
Je tâcherai de suivre ton conseil. Dans tous les cas, je te remercie encore grandement pour ton aide !

& Bonne soirée !