Копировать одноименные листы из файлов Excel в один файл Excel

Sub Nurzhan()
Dim di As Object, d$, f$, n, s As Object
  Set di = CreateObject("scripting.dictionary")
  di.comparemode = vbTextCompare
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку с файлами"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
    d = .SelectedItems(1) & "\"
  End With
  On Error GoTo 1
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  f = Dir(d & "*.xls*")
  While Len(f)
    With Workbooks.Open(d & f, , True)
      n = InStrRev(f, ".")
      If n Then f = Left$(f, n - 1)
      For Each s In .Sheets
        n = Trim$(s.Name)
        If di.exists(n) Then
          s.Copy , di(n).Sheets(di(n).Sheets.Count)
          ActiveSheet.Name = f
        Else
          s.Copy
          ActiveSheet.Name = f
          di.Add n, ActiveWorkbook
        End If
      Next
      .Close 0
    End With
    f = Dir
  Wend
  For Each n In di.keys
    di(n).SaveAs d & n & ".xlsx", xlOpenXMLWorkbook
    di(n).Close 0
  Next
  MsgBox "Создано файлов: " & di.Count, vbInformation
1 Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub