VBA Excel: Ajouter une colonne à tous les fichiers du dossier

Résolu/Fermé
Anna - 22 mars 2014 à 11:27
 Anna - 22 mars 2014 à 13:18
Bonjour,

Je travaille sur Excel 2010 et cherche un code VBA pour ajouter automatiquement une colonne entre B et C intitulée "Date" à tous les fichiers ".xlsx" de mon dossier (il en contient une dizaine); comment faire?

Je vous en remercie par avance!

2 réponses

Polux31
Messages postés
6917
Date d'inscription
mardi 25 septembre 2007
Statut
Membre
Dernière intervention
1 novembre 2016
1 193
22 mars 2014 à 12:04
Bonjour,

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

1
Bonjour Polux31,

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!
0
Polux31
Messages postés
6917
Date d'inscription
mardi 25 septembre 2007
Statut
Membre
Dernière intervention
1 novembre 2016
1 193
22 mars 2014 à 12:39
Le fichier qui contient la macro sera toujours dans le répertoire des fichiers à modifier ?
0
Oui toujours
0
Polux31
Messages postés
6917
Date d'inscription
mardi 25 septembre 2007
Statut
Membre
Dernière intervention
1 novembre 2016
1 193
22 mars 2014 à 12:46
Dans ce cas modifier la ligne 43 comme ceci:

myFile = Dir(ThisWorkbook.Path & "\*.xlsx")


Et la ligne 47 :

mTab(ind) = ThisWorkbook.Path & "\" & myFile


Quel est le message d'erreur sur la ligne 18 ?
0
Merci!

Je travaille sur une version en anglais d'Excel et le message est le suivant:
"Run-time error '9': Subscript out of range"
0
Bonjour,

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
0
Bonjour Abdel,

et merci pour le code qui fonctionne très bien! J'ai simplement fait une modification afin que la colonne soit insérée en C et non B mais sinon c'est parfait!

Merci encore!
0