Macro et recopie de cellules

Sub test()
Dim r As Range
'ici on définit la plage de cellule
Set r = Range(Cells(1, 2), Cells(65536, 2).End(xlUp))
For Each Cell In r
'ici on étudie les deux caractères de gauche de la cellule
Select Case Left(Cell, 2)
Case "11"
' si on trouve 11 on affiche l'adresse de la cellule
MsgBox Cell.Offset(1, 1).Address
MsgBox Cell.Offset(2, 1).Address
Case "18"
'idem
MsgBox Cell.Offset(0, 1).Address
MsgBox Cell.Offset(0, 2).Address
Case "23"
'idem
MsgBox Cell.Offset(1, 1).Address
MsgBox Cell.Offset(2, 1).Address
Case "57"
'idem
MsgBox Range(Cell.Offset(0, 1), Cell.Offset(2, 1)).Address
MsgBox Cell.Offset(0, 2).Address
End Select
Next
End Sub

Sub testII()
Dim r As Range
Dim r2 As Range
'ici on définit la plage de recopie
Set r2 = Sheets("souhaits").Cells(16, 2)
Set r = Range(Cells(1, 2), Cells(65536, 2).End(xlUp))
Application.ScreenUpdating = False
For Each Cell In r
Select Case Left(Cell, 2)
Case "11"
Cell.Offset(1, 1).Copy Destination:=r2
Cell.Offset(2, 1).Copy Destination:=r2.Offset(0, 1)
Case "18"
Cell.Offset(0, 1).Copy Destination:=r2.Offset(0, 2)
Cell.Offset(0, 2).Copy Destination:=r2.Offset(0, 3)
Case "23"
Cell.Offset(1, 1).Copy Destination:=r2.Offset(0, 4)
Cell.Offset(2, 1).Copy Destination:=r2.Offset(0, 5)
Case "57"
Cell.Offset(0, 1).Copy Destination:=r2.Offset(0, 6)
Cell.Offset(0, 2).Copy Destination:=r2.Offset(0, 7)
Cell.Offset(1, 1).Copy Destination:=r2.Offset(0, 8)
Cell.Offset(2, 1).Copy Destination:=r2.Offset(0, 9)
End Select
Next
[COLOR="Blue"]With Sheets("souhaits").Range("B16:K16")[/COLOR].Copy
    .PasteSpecial xlValues, xlNone, False, False
    .Columns.AutoFit
    .Interior.ColorIndex = xlNone
End With
End Sub

Sub Recherche_Fichier()

Dim FS As FileSearch
Dim Rep As String
Dim i As Integer

Rep = "Q:\bilans" 'ici entre le chemin du répertoire de tes 8 fichiers
Set FS = Application.FileSearch
With FS
      .LookIn = Rep
      .Filename = "*.xls"
      .Execute
  If .FoundFiles.Count = 0 Then
       MsgBox "fichier non trouvé"
       Exit Sub
  End If
End With

For i = 1 To FS.FoundFiles.Count
 copie_Données (FS.FoundFiles(i))
Next i

End Sub


Sub copie_Données(Non_Fichier As String)

Dim derlign As Long
Dim j As Long

Application.ScreenUpdating = False
Workbooks.Open Filename:=Non_Fichier
derlign = Workbooks("test1").Sheets("souhaits").Range("A65536").End(xlUp).Row

For j = 1 To Worksheets.Count 'ici remplace 1 par 6

Application.DisplayStatusBar = True
Application.StatusBar = "Traitement du fichier: " & Non_Fichier & " feuille " & Worksheets(j).Name & " en cours..."

   With Worksheets(j)
        Workbooks("test1").Sheets("souhaits").Range("A" & derlign + 1) = Mid(Non_Fichier, 11)
        .Range("C10,C11,C40").Copy
        Workbooks("test1").Sheets("souhaits").Range("B" & derlign + 1 & ":D" & derlign + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
        .Range("D40").Copy
        Workbooks("test1").Sheets("souhaits").Range("E" & derlign + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
        .Range("C64,C65,C240").Copy
        Workbooks("test1").Sheets("souhaits").Range("F" & derlign + 1 & ":H" & derlign + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
        .Range("D240").Copy
        Workbooks("test1").Sheets("souhaits").Range("I" & derlign + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
        .Range("C241,C242").Copy
        Workbooks("test1").Sheets("souhaits").Range("J" & derlign + 1 & ":K" & derlign + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
        derlign = Workbooks("test1").Sheets("souhaits").Range("A65536").End(xlUp).Row
  End With
  
Next j
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.StatusBar = False
Application.ScreenUpdating = True

End Sub