Erreur d'exécution 1004

**youyououj** · 24/02/2018, 23h59

Bonjour,
Je vous sollicite de nouveau votre aide pour un problème concernant un erreur d’exécution qui s'affiche a chaque fois que mon programme s’exécute. J'ai le code suivant:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 
Option Explicit
 
Sub CopPrincipale()
Dim Chemin As String, Fichier As String
Dim NbLg As Long
Dim tablo, dico, i, j, k, t, ln, v(), fdep, f
tablo = Range(Cells(1, 1), Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
    Set dico = CreateObject("Scripting.Dictionary")
 
    Set fdep = ActiveSheet
    Sheets.Add
    Set f = ActiveSheet
    fdep.Select
For i = 2 To UBound(tablo, 1)
        dico(tablo(i, 1)) = ""
    Next i
 
    k = dico.keys
    For i = 0 To dico.Count - 1
        'MsgBox k(i)
        ln = 0
        For t = 2 To UBound(tablo, 1)
            If k(i) = tablo(t, 1) Then
                ReDim Preserve v(UBound(tablo, 2), ln + 1)
                For j = 1 To UBound(tablo, 2)
                    v(j - 1, ln) = tablo(t, j)
                Next j
                ln = ln + 1
            End If
        Next t
  Application.ScreenUpdating = False
  Sheets("Principale").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:v" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:v" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
  End With
          With ActiveWorkbook
            .SaveAs ThisWorkbook.Path & "\" & " " & k(i)
            .Close
        End With
    Next i
 
    'f.Cells.Clear
    f.Select
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
End Sub
  MsgBox "Travail terminé."
End Sub
Sub Macro1()
'
' Macro1 Macro
'
 
'
    Sheets("Feuil7").Select
    ActiveWindow.SelectedSheets.Delete
End Sub

Le code a pour but de créer des classeurs a partir de feuille 1 et il nome le classeur par le contenu des cellules A1, A2, A3... après la création des classeurs, la feuille 2 nommée principale de classeur ci joint doit être copiée dans le nouveaux classeur crée en gardant la même mise en forme.
Vous trouviez ci jointe le classeur avec le code VBA
Merci en avance !