Fusion chiffriers et onglets

Dim OngletNom
Dim OngletDepart
Dim OngletColonne

Sub Initialise(Optional dummy As Byte)
  '### Noms, lignes de départ des données, colonne/base ###
  '### A adapter selon votre usage                      ###
OngletNom = Array("1.Inventaire", "2.Vulnérabilité", "Sommaire", "Detail")
OngletDepart = Array(9, 10, 7, 2)
OngletColonne = Array(1, 1, 4, 1)
  '########################################################
End Sub

Sub FusionOnglets()
Dim MyShell As Object
Dim MyFolder As Object
Dim Chemin$
Dim i&
Dim j&
Dim cpt&
Dim nbLig&
Dim nbCol&
Dim WBnew As Workbook
Dim WB As Workbook
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim Log$()
Call Initialise
Set MyShell = CreateObject("Shell.Application")
Set MyFolder = MyShell.BrowseForFolder( _
    0, "Choisissez le dossier contenant les classeurs à fusionner", 1)
If MyFolder Is Nothing Then Exit Sub
On Error Resume Next
Chemin$ = MyFolder.ParentFolder.ParseName(MyFolder.Title).Path & ""
If Err = 91 Then
  Chemin$ = Mid(MyFolder.Title, InStr(MyFolder.Title, ":") - 1, 2) & ""
  If Chemin$ = "" Then
    MsgBox "Veuillez choisir un autre dossier que le dossier ''" & MyFolder.Title & "''"
    Exit Sub
  End If
  Err.Clear
End If
With Application.FileSearch
  .LookIn = Chemin$
  .FileType = msoFileTypeExcelWorkbooks
  .Execute
  If .FoundFiles.Count = 0 Then
    MsgBox "Aucun classeur n'a été trouvé dans " & Chemin$
    Exit Sub
  End If
End With
Set WBnew = Workbooks.Add(xlWBATWorksheet)
For i& = 1 To 3
  WBnew.Sheets.Add
Next i&
For i& = 1 To 4
  WBnew.Sheets(i&).Name = OngletNom(i& - 1)
Next i&
Application.ScreenUpdating = False
For i& = 1 To Application.FileSearch.FoundFiles.Count
  Chemin$ = Application.FileSearch.FoundFiles(i&)
  Set WB = GetObject(Chemin$)
  WB.Windows(1).Visible = True
  For j& = LBound(OngletNom) To UBound(OngletNom)
    Set S = Nothing
    Set S = WB.Sheets(OngletNom(j&))
    If S Is Nothing Then
      cpt& = cpt& + 1
      ReDim Preserve Log$(1 To 1, 1 To cpt&)
      Log$(1, cpt&) = "La feuille ''" & OngletNom(j&) & _
          "'' n'existe pas dans " & Chemin$
      Err.Clear
    Else
      S.Activate
      nbLig& = S.Range(S.Cells(65536, OngletColonne(j&)), _
          S.Cells(65536, OngletColonne(j&))).End(xlUp).Row
      nbCol& = S.UsedRange.Columns.Count
      Set R = S.Range(S.Cells(OngletDepart(j&), 1), S.Cells(nbLig&, nbCol&))
      R.Copy
      Set S2 = WBnew.Sheets(OngletNom(j&))
      S2.Activate
      If S2.UsedRange.Address = "$A$1" And S2.Range("a1") = "" Then
        Set R = S2.Range("b" & S2.UsedRange.Rows.Count & "")
      Else
        Set R = S2.Range("b" & S2.UsedRange.Rows.Count + 1 & "")
      End If
      R.Select
      ActiveSheet.Paste
      R.Offset(0, -1) = WB.Name
      S2.[a1].Select
      Application.CutCopyMode = False
    End If
  Next j&
  WB.Close savechanges:=False
  Set WB = Nothing
Next i&
If Log$(1, 1) <> "" Then
If Err = 9 Then Exit Sub
Set S = WBnew.Sheets.Add(after:=WBnew.Sheets(WBnew.Sheets.Count))
S.Name = "Log"
S.Range(S.Cells(1, 1), S.Cells(UBound(Log$, 2), _
    UBound(Log$, 1))) = WorksheetFunction.Transpose(Log$)
S.Columns.AutoFit
End If
Application.ScreenUpdating = True
End Sub