VBA Excel: Ajouter une colonne à tous les fichiers du dossier
Résolu/Fermé
A voir également:
- VBA Excel: Ajouter une colonne à tous les fichiers du dossier
- Liste déroulante excel - Guide
- Formule excel - Guide
- Si et excel - Guide
- Aller à la ligne excel - Guide
- Mise en forme conditionnelle excel - Guide
2 réponses
Polux31
Messages postés
6917
Date d'inscription
mardi 25 septembre 2007
Statut
Membre
Dernière intervention
1 novembre 2016
1 204
22 mars 2014 à 12:04
22 mars 2014 à 12:04
Bonjour,
Code que j'ai déjà utilisé avec Excel 2007 et qu'il faut adapter.
Code que j'ai déjà utilisé avec Excel 2007 et qu'il faut adapter.
Option Explicit Private Const CHEMIN = "C:\MonDossier\" 'Mettre le chemin du dossier contenant les fichiers Sub AjouterColonne() Dim mTabFile() Dim i As Long Dim wb As Workbook Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False 'Récupération des fichiers Call RecupFichier(mTabFile) 'Boucle sur tous les fichiers For i = LBound(mTabFile()) To UBound(mTabFile()) Set wb = Workbooks.Open(mTabFile(i)) '*** /!\ Modifier la ligne suivante pour l'adapter à la feuille à modifier Set ws = wb.Sheets(1) 'Insertion d'une colonne avant la colonne C ws.Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'Titre de la colonne C "Date" ws.Range("C1").Value = "Date" 'Sauvegarde du fichier et libération des objets wb.Save Set ws = Nothing wb.Close Set wb = Nothing Next i Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub RecupFichier(ByRef mTab) Dim myFile As String Dim ind As Long myFile = Dir(CHEMIN & "*.xlsx") Do While Len(myFile) > 0 ReDim Preserve mTab(ind) mTab(ind) = CHEMIN & myFile myFile = Dir() Loop End Sub
Bonjour,
Une alternative à la proposition de Polux31:
Cdlt
Une alternative à la proposition de Polux31:
Sub Ajout_ColonneB()
Dim wbbase As Workbook
Dim ext As String, chemin As String
Dim fs As Object, f As Object, sf As Object
Dim wbo As Variant
Application.ScreenUpdating = False
Set wbbase = ActiveWorkbook
chemin = wbbase.Path
ext = "xlsx"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(chemin)
Set sf = f.Files
For Each wbo In sf ' parcourir les fichiers du répertoire et tester le nom du classeur et l'extension
If wbo.Name <> wbbase.Name And Right(wbo.Name, Len(ext)) = ext Then
Workbooks.Open (chemin & "\" & wbo.Name)
Sheets(1).Activate
ActiveSheet.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Range("B1").Value = "Date"
Workbooks(wbo.Name).Close SaveChanges:=True
End If
Next wbo
Set f = Nothing: Set fs = Nothing: Set sf = Nothing
Application.ScreenUpdating = True
End Sub
Cdlt
22 mars 2014 à 12:28
Merci pour le code.
Mais une erreur apparaît lorsque je l'exécute, surlignant la ligne 18.
D'autre part, y'aurait-il par hasard une possibilité qu'il reprenne automatiquement le chemin du répertoire dans lequel se trouve le fichier contenant la macro au lieu de l'indiquer dans le code?
Merci beaucoup!
22 mars 2014 à 12:39
22 mars 2014 à 12:41
22 mars 2014 à 12:46
Et la ligne 47 :
Quel est le message d'erreur sur la ligne 18 ?
22 mars 2014 à 12:49
Je travaille sur une version en anglais d'Excel et le message est le suivant:
"Run-time error '9': Subscript out of range"