Macro VBA

[inviteb7e1df6b]

Salut à tous,

Je sollicite votre aide pour créer une macro.
Je cherche à créer une macro qui puisse faire la chose suivante :
OUvrir des fichiers dans un dossiers
Lire sur chaque onglet si en cellule A1 il y a un nom, si oui copier les données des colonnes A à D sur les colonnes AA à AD.
Refermer chaque fichier et enregistrer.
N'ayant aucune connaissance de code, je galere un peu bcp j'ai essaye

Workbooks.Open Filename:="test.xls"

Sub OuvrirClasseur()

Dim strFichier As String



Const strRepertoire = "test"
If Range("A1").Value = 0 Then


End Sub

Si quelqu'un peut m'aider ca serait super sympa
merci par avance
-----

[Dormeur74]

Je suppose que ce que tu appelles un "onglet" correspond à une "feuille" du classeur ?

[Dormeur74]

Voici ta macro. Au passage, très proche d'une demande toute récente. Tu mets ta macro dans un fichier Excel auquel tu donneras le nom de ton choix et colleras ce fichier dans le dossier à traiter. Il suffit ensuite d'exécuter la macro.
Passe un peu de temps dessus si tu veux apprendre VBA.

Sub Macro1()
    Dim I, J As Integer
    Dim Tableau() As String
    Dim NbrFiles As Integer
    Dim Fichier As Workbook
    Dim XL As Application
  
    Set XL = Excel.Application
    
    'On met dans un tableau les fichiers Excel du dossier contenant la macro
    With XL.FileSearch
        .LookIn = ActiveWorkbook.Path
        .Filename = "*.xls*" ' on prend les extensions XLS et XLSX
        If .Execute > 0 Then
            NbrFiles = .FoundFiles.Count
            ' On redimensionne le tableau dynamiquement
            ReDim Tableau(NbrFiles)
            ' On charge le tableau avec les noms des fichiers trouvés
            For I = 1 To NbrFiles
                Tableau(I) = .FoundFiles(I)
            Next I
        Else
            MsgBox "Ce dossier ne contient pas de fichiers Excel."
            Exit Sub
        End If
    End With
    
    ' On copie les cellules A1:D1 des feuilles lorsque A1 n'est pas vide
    For I = 1 To NbrFiles
       If Tableau(I) <> ThisWorkbook.FullName Then
            Set Fichier = Workbooks.Open(Tableau(I))
            ' On traite toutes les feuilles du classeur
            For J = 1 To Sheets.Count
              Worksheets(J).Select
              If Range("A1").Value <> "" Then
                Range("A1").Offset(0, 26) = Range("A1")
                Range("B1").Offset(0, 26) = Range("B1")
                Range("C1").Offset(0, 26) = Range("C1")
                Range("D1").Offset(0, 26) = Range("D1")
              End If
            Next J
            ' On enregistre le classeur sans message d'alerte
            ' S'il y a un danger, supprimer les deux lignes .DisplayAlerts ci-dessous
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Tableau(I)
            Application.DisplayAlerts = True
            ActiveWorkbook.Close False
            Set Fichier = Nothing
       End If
    Next I
    Set XL = Nothing
End Sub

[inviteb7e1df6b]

Bonjour ,

Oui je voulais dire une feuille.

Merci pour ton aide.

Justement, je dois réaliser des macros différentes , je vais me servir de celle la en base.

Merci encore

[A voir en vidéo sur Futura]

[inviteb7e1df6b]

Bonjour,

Juste deux questions :
Concernant la partie recherche, ca n'existe plus dans office 2007. Sais tu comment je peux contourner ce probleme? Sur le net, j'ai trouvé des extensions mais je ne peux malheureusement les installées car je suis sur un pc du travail.
Deuxieme question
J'ai tenté de changer la macro pour :
--> Intégrer une modification, une condition.
--> Attraper des un bloc de colonnes et le dupliquer plus loin. Pour que ca aille plus vite j'avais pensé rajouter qqe chose du genre While Ligne <300. Est ce que cela peut marcher?

Sub nouvellemacro()

    Dim I, J As Integer
    Dim Tableau() As String
    Dim NbrFiles As Integer
    Dim Fichier As Workbook
    Dim XL As Application
  
    Set XL = Excel.Application
    
    'On met dans un tableau les fichiers Excel du dossier contenant la macro
    With XL.FileSearch
        .LookIn = ActiveWorkbook.path
        .Filename = "*.xls*" ' on prend les extensions XLS et XLSX
        If .Execute > 0 Then
            NbrFiles = .FoundFiles.Count
            ' On redimensionne le tableau dynamiquement
            ReDim Tableau(NbrFiles)
            ' On charge le tableau avec les noms des fichiers trouvés
            For I = 1 To NbrFiles
                Tableau(I) = .FoundFiles(I)
            Next I
        Else
            MsgBox "Ce dossier ne contient pas de fichiers Excel."
            Exit Sub
        End If
    End With
    
    ' On copie les cellules A1:D1 des feuilles lorsque A1 n'est pas vide
    For I = 1 To NbrFiles
       If Tableau(I) <> ThisWorkbook.FullName & cell(A1) = "Données" Then
       
       
            Set Fichier = Workbooks.Open(Tableau(I))
            ' On traite toutes les feuilles du classeur
            For J = 1 To Sheets.Count
              Worksheets(J).Select
              If Range("A1").Value <> "" Then
              
                Range("A:D).Offset(0, 26) = Range("F:G")
                
              End If
            Next J
            ' On enregistre le classeur sans message d'alerte
            ' S'il y a un danger, supprimer les deux lignes .DisplayAlerts ci-dessous
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Tableau(I)
            Application.DisplayAlerts = True
            ActiveWorkbook.Close False
            Set Fichier = Nothing
       End If
    Next I
    Set XL = Nothing
End Sub

[Dormeur74]

Il faut impérativement que tu règles ce problème de .Filesearch avant toute chose. Regarde ici. On reprend dès que tu as réglé ce pb. Je n'ai malheureusement que la v. 2003. Il faudrait que tu sollicite l'administrateur de ton PC de travail.
Pour le reste, toutes les manips sont possibles.

[inviteb7e1df6b]

C'est complétement bloqué!
Du coup, j'ai une solution de contournement je souhaite mettre l'adresse des fichiers excel directement dans le code.
Quelle fonction je dois utiliser pour lui dire d'appliquer la macro sur cette série de fichiers?.

Merci

[Dormeur74]

Ne le mets pas dans le dur, ce n'est pas propre.
Demain je me penche sur une façon plus élégante de contourner le problème du .FileSearch qui a disparu avec la version 2007.

[Dormeur74]

En fait, c'est plus simple avec la fonction Dir(). Essaye ceci.

Option Explicit

Sub Macro1()
    Dim I, J As Integer
    Dim Tableau() As String
    Dim NbrFichiers As Integer
    Dim NomFichier As String
    Dim Fichier As Workbook
      
    'On met dans un tableau les fichiers Excel du dossier contenant la macro
    NbrFichiers = 0
    NomFichier = Dir$(CurDir & "\", vbNormal)
    While NomFichier <> ""
        ' On ne retient ici que les fichiers portant l'extension XLS ou XLSX
        If NomFichier <> ThisWorkbook.Name And (UCase(Right(NomFichier, 4)) = ".XLS" Or UCase(Right(NomFichier, 5)) = ".XLSX") Then
            NbrFichiers = NbrFichiers + 1
            ' On redimensionne le tableau de façon dynamique en protégeant le contenu
            ReDim Preserve Tableau(NbrFichiers)
            Tableau(NbrFichiers) = NomFichier
        End If
        NomFichier = Dir$
    Wend
    
    ' On copie les cellules A1:D1 des feuilles lorsque A1 n'est pas vide
    For I = 1 To NbrFichiers
       If Tableau(I) <> ThisWorkbook.FullName Then
            Set Fichier = Workbooks.Open(Tableau(I))
            ' On traite toutes les feuilles du classeur
            For J = 1 To Sheets.Count
              Worksheets(J).Select
              If Range("A1").Value <> "" Then
                Range("A1").Offset(0, 26) = Range("A1")
                Range("B1").Offset(0, 26) = Range("B1")
                Range("C1").Offset(0, 26) = Range("C1")
                Range("D1").Offset(0, 26) = Range("D1")
              End If
            Next J
            ' On enregistre le classeur sans message d'alerte
            ' S'il y a un danger, supprimer les deux lignes .DisplayAlerts ci-dessous
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Tableau(I)
            Application.DisplayAlerts = True
            ActiveWorkbook.Close False
            Set Fichier = Nothing
       End If
    Next I
End Sub

[inviteb7e1df6b]

Bonjour et merci

,j’ai mis l’adresse du dossier où se trouve un fichier de test
C:\document\test\classeur1.xls
Dans le tableau je renseigne
C:\document\test\
Mais la macro commence à tourner sur tous les fichiers se trouvant dans
C:\document\

Je ne sais pas pourquoi ?

[Dormeur74]

Tu n'as à mettre l'adresse du dossier où se trouvent les fichiers à traiter nulle part. La macro connaît le nom de ce dossier grâce à la fonction Curdir().
Tu prends la macro telle quelle et tu la colles dans un fichier Excel auquel tu donneras le nom que tu veux. Là non plus tu n'auras pas à déclarer le nom du classeur contenant la macro grâce à ThisWorkbook.Name.
Ensuite tu lances la macro. Elle va rechercher tous les classeurs (*.xls et *.xlsx) qui se trouvent dans le dossier contenant la macro, et va modifier le contenu de chaque feuille de chaque classeur en collant en AA1, AB1, AC1 et AD1 les valeurs des cellules A1, B1, C1 et D1 chaque fois que A1 n'est pas vide.

[inviteb7e1df6b]

Merci .
J’ai deux questions.
Je souhaite plutôt que la macro ouvre spécifiquement des sous dossiers.
 Je n’ai aucune idée de comment faire cela.
Je souhaite que la macro copie colle, uniquement si en cellule A1 il y a une valeur spécifique.
 Pour ca j’ai une idée.

[Dormeur74]

Ouvrir des sous-dossiers ? Ce n'était pas du tout dans l'expression de ton besoin. Maintenant, il faut que tu te penches sur la récursivité. Malheureusement, je ne vais pas avoir le temps de le faire. A l'avenir, fais très attention à la rédaction de tes cahiers des charges.