Problème Excel2007

Private Sub RégénérerCLasseur()
Dim wbkOrg As Workbook
Dim wbkDst As Workbook
Dim wshOrg As Worksheet
Dim wshDst As Worksheet
Dim stlOrg As Style
Dim stlDst As Style
Dim cmtDst As Comment
Dim shpDst As Shape
Dim Nom As Name
Dim Nomfichier As String

  'Sélection du fichier
  On Error Resume Next
  Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = False
  Application.FileDialog(msoFileDialogFilePicker).Show
  Nomfichier = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
  If Nomfichier = "" Then Exit Sub
  On Error GoTo 0
  Set wbkOrg = Workbooks.Open(Nomfichier)
  Set wbkDst = Workbooks.Add(xlWBATWorksheet)
  'Fusionner les styles
  Application.DisplayAlerts = False           'pour éviter le messages concernant les styles de même nom
  wbkDst.Styles.Merge Workbook:=wbkOrg
  Application.DisplayAlerts = True
  'créer les feuilles
  For Each wshOrg In wbkOrg.Worksheets
    Set wshDst = wbkDst.Worksheets(wshOrg.Index)
    wshDst.Name = wshOrg.Name
    wshDst.Tab.ColorIndex = wshOrg.Tab.ColorIndex
    'copier les principales options d'affichage(quadrillage, onglets, ...)
    wshDst.Activate
    wshOrg.Activate
    Windows(wbkDst.Name).Zoom = Windows(wbkOrg.Name).Zoom
    Windows(wbkDst.Name).DisplayGridlines = Windows(wbkOrg.Name).DisplayGridlines
    Windows(wbkDst.Name).DisplayHeadings = Windows(wbkOrg.Name).DisplayHeadings
    Windows(wbkDst.Name).DisplayWorkbookTabs = Windows(wbkOrg.Name).DisplayWorkbookTabs
    Windows(wbkDst.Name).DisplayHorizontalScrollBar = Windows(wbkOrg.Name).DisplayHorizontalScrollBar
    Windows(wbkDst.Name).DisplayVerticalScrollBar = Windows(wbkOrg.Name).DisplayVerticalScrollBar
    Windows(wbkDst.Name).DisplayZeros = Windows(wbkOrg.Name).DisplayZeros
    'feuille suivante
    If wbkOrg.Worksheets.Count > wbkDst.Worksheets.Count Then wbkDst.Worksheets.Add After:=wshDst
  Next wshOrg
  'copier les noms
  For Each Nom In wbkOrg.Names
    If InStr(1, Nom.RefersTo, "#REF") = 0 Then wbkDst.Names.Add Nom.Name, Nom.RefersTo
  Next Nom
  'copier le contenu de chaque feuille
  For Each wshOrg In wbkOrg.Worksheets
    Set wshDst = wbkDst.Worksheets(wshOrg.Name)
    'copier toutes les cellules
    Application.DisplayAlerts = False           'pour éviter les messages concernant la copie des noms
    wshOrg.Cells.Copy Destination:=wshDst.Cells
    Application.DisplayAlerts = True
    'Copier les formules (supprime les éventuelles liaisons crées avec l'ancien classeur)
    wshDst.UsedRange.Formula = wshOrg.UsedRange.Formula
    'repositionner les commentaires
    For Each cmtDst In wshDst.Comments
      cmtDst.Shape.Top = wshOrg.Range(cmtDst.Parent.Address).Comment.Shape.Top
      cmtDst.Shape.Left = wshOrg.Range(cmtDst.Parent.Address).Comment.Shape.Left
    Next cmtDst
    'repositionner les objets
    For Each shpDst In wshDst.Shapes
      If shpDst.Type <> msoComment Then
        shpDst.LockAspectRatio = msoFalse
        shpDst.Height = wshOrg.Shapes(shpDst.Name).Height
        shpDst.Width = wshOrg.Shapes(shpDst.Name).Width
        shpDst.Top = wshOrg.Shapes(shpDst.Name).Top
        shpDst.Left = wshOrg.Shapes(shpDst.Name).Left
        shpDst.LockAspectRatio = wshOrg.Shapes(shpDst.Name).LockAspectRatio
      End If
    Next shpDst
  Next wshOrg
  wbkOrg.Saved = True
  wbkDst.Worksheets(1).Activate
  
End Sub