Perte de Collage

Bonjour je reviens avec un sujet aussi solide que le Titanic...

Mon but est de recuperer les valeurs d'une dizaine de classeur et de coller l'ensemble des données dans un nouveau classeur.

dans l'idée chaque onglet des fichiers" sources" sera copié dans chaque onglet du fichier "Perte de collage".

Je récupère normalement que les cellules visible après filtrage que j'essaye désespérément de collé dans mon classeur "Perte de collage". Le fichier Source 1 doit etres dans un repertoire \Commande a la racine du fichier "Perte de collage"

Sub ListingFichiers()
Dim rep As String
Dim Fichier As File
Dim Fichier2 As String
Dim FichSource As String
Dim i As Integer
Dim Nc, Cel As Range

Application.ScreenUpdating = False

   FichSource = ActiveWorkbook.Name
  ' rep = ActiveWorkbook.Path & "\Commande\"

   Set fs = CreateObject("Scripting.FileSystemObject")
   Set d = fs.GetFolder(ThisWorkbook.Path & "\Commande\")      'remplace ce chemin par celui que tu veux, avec le nom de ton dossier à la fin
   For Each Fichier In d.Files      'tu utilises la collection Files de ton dossier d
      Workbooks.Open (Fichier)
      Fichier2 = Fichier.Name
      For i = 1 To 1
      Workbooks(Fichier2).Activate

         With Workbooks(Fichier2).Sheets(i)
         'With Sheets(i)
        .Unprotect
'        .Select
        On Error Resume Next
        .Columns("A:W").EntireColumn.Hidden = False
        .Columns("C:I").EntireColumn.Hidden = True
        .Columns("L:T").EntireColumn.Hidden = True
        .Columns("W").EntireColumn.Hidden = True

        'End With
         Sheets(i).Visible = True
         n = .Cells(Rows.Count, "J").End(xlUp).Row
        .Range("A2:W" & n).SpecialCells(xlCellTypeVisible).Copy
         .Protect
         End With

         Workbooks(FichSource).Activate
         With Sheets(i)
            .Range("A2").Select
            .Paste
         End With
        Next i
         Workbooks(Fichier2).Close False

   Next Fichier
End Sub

Voilà ce que j'ai pondu mais mon collage ne fonctionne pas ( meme pas un petit message d'erreur) pour le 1er onglet du 1er classeur c'est mal partie....

Si un oeil charitable arrive a creuser un peu et à trouver ou est l'os je suis prenneur,

Merci à vous

Bonjour,

il faut attribue une référence à chaque objet,

par exemple,

Set wk1 = ThisWorkbook
Set wk2 = Workbooks("fichier à ouvrir.xlsx")
Set Source = wk1.Sheets("Feuil2").Range("A1:B2")
Set destin = wk2.Sheets("Feuil4").Range("A1:B2")
Source.Copy destin

Bonjour SabV

Je penses avoir suivi ton conseil correctement mais le résultat reste le même....

Sub ListingFichiers()
Dim rep As String
Dim Fichier As File
Dim Fichier2 As String
Dim FichSource As String
Dim i As Integer
Dim Nc, Cel As Range

Application.ScreenUpdating = False

   FichSource = ActiveWorkbook.Name
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set d = fs.GetFolder(ThisWorkbook.Path & "\Commande\")      'remplace ce chemin par celui que tu veux, avec le nom de ton dossier à la fin
   For Each Fichier In d.Files      'tu utilises la collection Files de ton dossier d
      Workbooks.Open (Fichier)
      Fichier2 = Fichier.Name
      For i = 1 To 1

    With Workbooks(Fichier2).Sheets(i)

        .Unprotect
'
        On Error Resume Next
        .Columns("A:W").EntireColumn.Hidden = False
        .Columns("C:I").EntireColumn.Hidden = True
        .Columns("L:T").EntireColumn.Hidden = True
        .Columns("W").EntireColumn.Hidden = True
        n = .Cells(Rows.Count, "J").End(xlUp).Row
         Set Source = Workbooks(FichSource).Sheets(i).Range("A2:W" & n)
    End With
         b = 2

         Set destin = Workbooks(Fichier2).Sheets(i).Range("A" & b)
         Source.SpecialCells(xlCellTypeVisible).Copy destin

        Next i
        ' Workbooks(Fichier2).Close False

   Next Fichier
End Sub

Voici la solution qui passe par des équivalences de range entre deux feuilles c'est hyper rapide et ça à le mérite de fonctionner

Sub StartMacroExportData()
Dim Fichier As File
Dim Fichier2 As String
Dim wb As Workbook
Dim OpenWb As Workbook
Dim CopyRange As Range
Dim PasteRange As Range
Dim n As Integer, m As Integer

Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetFolder(ThisWorkbook.Path & "\Commande\")
Set wb = ActiveWorkbook
For Each Fichier In d.Files
Set OpenWb = Workbooks.Open(Fichier)

For i = 14 To 14
 With OpenWb.Sheets(i)

        .Visible = True
        .Select
        .Unprotect '
                On Error Resume Next

         n = .Cells(Rows.Count, "J").End(xlUp).Row
       'Plage = .Range("J2:V" & n)
       Set CopyRange = Range("A2:V" & n)
         .Protect
 End With

With wb.Sheets(i)
.Activate
 m = wb.Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row + 1
Set PasteRange = wb.Sheets(i).Range(Cells(m, 1), Cells(n + m - 2, 22))
PasteRange.Value2 = CopyRange.Value2 ' <------------------------------------------------------------------Trop fort !!
'.Columns("A:W").EntireColumn.Hidden = False
        .Columns("C:I").Delete
        .Columns("L:T").Delete
        .Columns("W").Delete
'Selection.PasteSpecial Paste:=xlPasteValues
End With
Set CopyRange = Nothing
Set PasteRange = Nothing
Next i
Workbooks(Fichier2).Close False
Next
End Sub