Voici le code entier :
Option Explicit
Dim ListFic(10) As String
Function OuvreCopie(CheminFic As String)
Dim wb As Workbook, Mwb As Workbook
Dim ws As Worksheet, Mws As Worksheet
Dim Societe As String, Attn As String, Comercial As String, NoSem As Integer
Dim LigDeb As Integer, LigFin As Integer
'ATTRIBUTION
Set Mws = ActiveWorkbook.Worksheets("Recap") '........feuille "Recap" du classeur d'origine
Set ws = ActiveWorkbook.Worksheets("Pedido")
Set wb = ActiveWorkbook
'EXECUTION
ws.Rows("14:14").Select '.............................selectionne ligne2
Range(Selection, Selection.End(xlDown)).Select '......selectionne jusqu'en bas, sans la ligne total dario
Selection.SpecialCells(xlCellTypeVisible).Select '....ne selectionne que les lignes non masquées
Selection.Copy '......................................copie
Mws.Activate '........................................active la feuille 1 dans le classeur d'origine
Range("a11").Select '.................................selectionne a11
Selection.End(xlDown).Offset(1, 0).Select '...........saute jusqu'en bas de la liste, puis décale encore de 1 ligne vers le bas
ActiveSheet.Paste '...................................colle
Application.CutCopyMode = False '.....................sort du mode copie (pointillé clignotant)
LigDeb = Selection.Row '..............................définit le no de lign edu début et de la fin de la copie
LigFin = LigDeb + Selection.Rows.Count - 1
ws.Activate '.........................................récuppère les infos
Societe = Range("h1").Value
Attn = Range("h2").Value
Comercial = Range("d9").Value
NoSem = Range("e7").Value
Mws.Activate '........................................copie les infos sur toute la hauteur de la selection
Range("n" & LigDeb, "n" & LigFin).Value = Societe
Range("o" & LigDeb, "o" & LigFin).Value = Attn
Range("p" & LigDeb, "p" & LigFin).Value = NoSem
Range("q" & LigDeb, "q" & LigFin).Value = Comercial
'FERMETURE
wb.Close
Set ws = Nothing
Set Mws = Nothing
End Function
Sub BoucleFichiers()
Dim Chemin As String, Fichier As String
Dim i As Integer, j As Integer
Erase ListFic
'Application.ScreenUpdating = False ' supprime l'affichage de toutes les étapes
'Définit le répertoire contenant les fichiers
Chemin = Range("c1").Value & "\semaine" & Range("e5").Value & "\"
i = 1
j = 1
'Boucle sur tous les fichiers xlsm du répertoire...
Fichier = Dir(Chemin & "*.xlsm")
'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers:
'Fichier = Dir(Chemin & "*.*")
'... et écrit le résultat dans le tableau ListFic.
Do While Len(Fichier) > 0
ListFic(i) = Chemin & Fichier
i = i + 1
Fichier = Dir()
Loop
'Ouvre successivement les fichiers et récuppère les données (grâce à la fonction)
Do While ListFic(j) <> ""
OuvreCopie (ListFic(j))
j = j + 1
Loop
'Masque tous les jours sauf celui en A1
DisplayJourSem = Worksheets("Feuil").Range("A1").Value
Select Case DisplayJourSem
Case "Lunes"
Range("h1:l1").Select
Case "Martes"
Application.Union(Range("g1:g1"), Range("i1:l1")).Select
Case "Miercoles"
Application.Union(Range("g1:h1"), Range("j1:l1")).Select
Case "Jueves"
Range("g1:i1", "k1:l1").Select
Application.Union(Range("g1:i1"), Range("k1:l1")).Select
Case "Viernes"
Range("g1:j1", "l1").Select
Application.Union(Range("g1:j1"), Range("l1:l1")).Select
Case "Sabado"
Range("g1:k1").Select
Case "Domingo"
MsgBox ("Pas de dimanche dans le tableau")
Case Else
MsgBox ("Mauvaise saisie dans la cellule a1")
End Select
Selection.EntireColumn.Hidden = True
'Application.ScreenUpdating = True ' ré-allume l'affichage de toutes les étapes
MsgBox "fin des opérations"
End Sub