Créer une boucle pour l'ensemble des fichiers d'un dossier

Bonjour,

remplace :

            If Cells(1, 4).Value = "" Then Cells(1, 4).Select
             Else
            Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If

par :

            If Cells(1, 4).Value = "" Then 
                Cells(1, 4).Select
             Else
               Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If

Bonjour,

Lorsque la macro arrive à ce niveau, j'ai le message d'erreur "1004 : Erreur définie par l'application ou l'objet" qui apparait !

Or j'utilise cette même fonction if/else dans mon tout premier code et il fonctionne très bien !

Cells(1, 4).End(xlDown).Offset(1, 0).Select

Ci-dessous mon code sans tout les copier/coller :

Option Explicit

Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
     ' Supprimer l'ensemble des valeurs existantes
    Range("D2:K1261").Delete

    Chemin = "C:\Users\Joëlle & Sébastien\Documents\01. SEBA\Safran\01. Vehicules Test\DATA\"
    Extens = "*.xlsx"
    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Set wb = Application.Workbooks.Open(Chemin & Fichier)
            '*********************************************************
            '    ICI, tu appelles ta macro de copier/coller
            '*********************************************************
            Call Copier_Coller(wb)
            Workbooks(Fichier).Close True
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub

Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
    Set WbDest = Workbooks("Classeur_Test.xlsm")

    With Wbk
        With .Worksheets("Relevés de mesures") '********************************* NOM DE LA FEUILLE A ADAPTER
            .Range("B11:G11").Copy
            WbDest.Worksheets("Feuil1").Activate
            If Cells(1, 4).Value = "" Then
            Cells(1, 4).Select
            Else
            Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            'Suite des copier/coller
            End with
        End With
    End Sub
       

Merci

Bonjour,

Essaye de remplacer :

            WbDest.Worksheets("Feuil1").Activate
            If Cells(1, 4).Value = "" Then
            Cells(1, 4).Select
            Else
            Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If

par :

             WbDest.Worksheets("Feuil1").Select
             If WbDest.Worksheets("Feuil1").Cells(1, 4).Value = "" Then
                WbDest.Worksheets("Feuil1").Cells(1, 4).Select
            Else
                WbDest.Worksheets("Feuil1").Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If

Bonjour,

Vraiment désolé mais j'ai toujours l'erreur 1004 : la méthode select de la classe worksheets à échoué.

J'ai remplacé select par activate... et là l'erreur "1004 : Erreur définie par l'application ou l'objet" qui réapparait !

Merci

Bonjour,

Je sèche sur l'erreur "1004 : La méthode select de la classe worksheets a échoué" !!!!

Merci pour votre aide

Sébastien

Option Explicit

Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
     ' Supprimer l'ensemble des valeurs existantes
    Range("D2:K1261").Delete

    Chemin = "C:\Users\Joëlle & Sébastien\Documents\01. SEBA\Safran\01. Vehicules Test\DATA\"
    Extens = "*.xlsx"
    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Set wb = Application.Workbooks.Open(Chemin & Fichier)
            '*********************************************************
            '    ICI, tu appelles ta macro de copier/coller
            '*********************************************************
            Call Copier_Coller(wb)
            Workbooks(Fichier).Close True
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub

Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
    Set WbDest = Workbooks("Classeur_Test.xlsm")

    With Wbk
        With .Worksheets("Relevés de mesures") '********************************* NOM DE LA FEUILLE A ADAPTER
            .Range("B11:G11").Copy
            WbDest.Worksheets("Feuil1").Select
             If WbDest.Worksheets("Feuil1").Cells(1, 4).Value = "" Then
                WbDest.Worksheets("Feuil1").Cells(1, 4).Select
            Else
                WbDest.Worksheets("Feuil1").Cells(1, 4).End(xlDown).Offset(1, 0).Select
            End If
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
          End With
    End With
End Sub

Bonjour,

Essaye d'activer le classeur ici :

Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
    Set WbDest = Workbooks("Classeur_Test.xlsm")
    WbDest.Activate '------- ICI