Macro pour création de deux fichiers Excel

'#### A adapter selon votre usage ###
Const FEUILLE_SOURCE As String = "Données"
Const MY_RESEAU As String = "RESEAU"
Const MY_SIEGE As String = "SIEGE"
'####################################

Sub MakeReseauSiege()
Dim WBD As Workbook 'classeur Données source
Dim WBR As Workbook 'classeur RESEAU ou SIEGE
Dim NeoClasseurs
Dim S As Worksheet
Dim lastRow&
Dim i&
Dim k&
Dim var
NeoClasseurs = Array(MY_RESEAU, MY_SIEGE)
Set WBD = ActiveWorkbook
On Error Resume Next
Set S = WBD.Sheets(FEUILLE_SOURCE)
If Err <> 0 Then
  MsgBox "La feuille ''" & FEUILLE_SOURCE & "'' est introuvable"
  Exit Sub
End If
On Error GoTo Erreur
lastRow& = S.[a65536].End(xlUp).Row
var = S.Range("a1:a" & lastRow& & "")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For k& = LBound(NeoClasseurs) To UBound(NeoClasseurs)
  Set WBR = Workbooks.Add(xlWBATWorksheet)
  WBD.Sheets(FEUILLE_SOURCE).Copy After:=WBR.Sheets(1)
  WBR.Sheets(1).Delete
  Set S = WBR.ActiveSheet
  S.Name = S.Name & "_" & NeoClasseurs(k&)
  For i& = lastRow& To 1 Step -1
    If var(i&, 1) <> NeoClasseurs(k&) Then
      S.Rows(i&).Delete
    End If
  Next i&
  Select Case k&
    Case 0
      S.Columns("D:IV").Delete
    Case 1
      S.Range("A:A,F:IV").Delete
      S.Columns("B:B").Cut
      S.Columns("E:E").Select
      S.Paste
      S.Columns("B:B").Delete
  End Select
  S.[a1].Select
Next k&
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & _
     vbCrLf & Err.Description
End Sub