Discussion :

[Bernard67]

Bonjour le forum,
Je fais appel à vous pour un probleme de macro que je n'arrive pas à solutionner. Plus je cherche et moins je trouve l'erreur.
Voici le code :

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
Sub decoupage()
 
    'dossier est une variable de type chaine de caractère (String) qui contient le répertoire courant
    Dim dossier As String
    'Dossier est une variable qui indique ou sont sauvegardes les fichiers
    dossier = ActiveWorkbook.Path & "\"
 
    'nom du classeur
    Dim classeurName As String
    classeurName = ActiveWorkbook.Name
 
    'nom de la feuille
    Dim feuilleName As String
    feuilleName = ActiveSheet.Name
 
    'on crée une collection (groupe de cellule)
    Dim coll As Collection
    Set coll = New Collection
 
    'première ligne de donnée
    debut = 2
 
    'On classe la feuille par colonne A
    Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
 
    For n = 2 To Workbooks(classeurName).Sheets(feuilleName).Range("A65536").End(xlUp).Row
      On Error Resume Next
      coll.Add Workbooks(ActiveWorkbook.Name).Sheets(ActiveSheet.Name).Range("A" & n), CStr(Workbooks(classeurName).Sheets(feuilleName).Range("A" & n))
      On Error GoTo 0
    Next n
 
    For n = 1 To coll.Count
      ligne = 2
 
      'pour chaque nom de "coll", on crée un nouveau classeur
 
      'on désactive excel qui râle
      Application.DisplayAlerts = False
 
      'on créé un nouveau classeur
      Set Wbk = Workbooks.Add
 
      'on supprime les feuilles par default pour une feuille du nom de la colonne "coll(n)"
      Wbk.Sheets("Feuil1").Delete
      Wbk.Sheets("Feuil2").Delete
      Wbk.Sheets("Feuil3").Name = coll(n)
 
      'on recopie la première ligne de titre
      Workbooks(classeurName).Sheets(feuilleName).Rows(1).Copy Destination:=ActiveSheet.Rows(1)
 
      'on recopie toutes les lignes avec le bon nom de colonne
      For m = debut To Workbooks(classeurName).Sheets(feuilleName).Range("A65536").End(xlUp).Row
        If Workbooks(classeurName).Sheets(feuilleName).Range("A" & m) = coll(n) Then
          Workbooks(classeurName).Sheets(feuilleName).Rows(m).Copy Destination:=ActiveSheet.Rows(ligne)
          ligne = ligne + 1
        End If
      Next m
      debut = debut + ligne - 3
 
      'on sauvegarde dans le dossier du classeur de départ
      Wbk.SaveAs dossier & coll(n)
      'on ferme le classeur crée lorsque la sauvegarde c'est bien passée
      Wbk.Close True
    Next n
End Sub

Lamacro bloque sur la 3eme ligne en partant de la fin C'est à dire :Wbk.Close True

Quelqu'un aurait il la raison ?
Merci.

[mayekeul]

bonjour,

peut-être que si tu nous dis quel est le message d'erreur, on en auras une


ceci dis tu peux déjà retirer le "true" , il ne sert à rien, tu viens déjà juste de le sauver à la ligne précédente

[Bernard67]

Merci mayekeul de te pencher sur mon problème.

J'ai supprimer le TRUE, maintenant cette ligne se met en jaune :

Code :

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

Wbk.Sheets("Feuil1").Delete

[mercatog]

une proposition alternative

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
Sub decoupage()
Dim tWbk As Workbook, Wbk As Workbook
Dim aSht As Worksheet, Sht As Worksheet
Dim Dossier As String
Dim coll As New Collection
Dim LastLig As Long, n As Long
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Set tWbk = ThisWorkbook
Dossier = tWbk.path & "\"
Set aSht = tWbk.ActiveSheet
With aSht
    LastLig = .Cells(Rows.Count, "A").End(xlUp).Row
    For n = 2 To LastLig
    On Error Resume Next
        coll.Add .Range("A" & n).Value, CStr(.Range("A" & n).Value)
    On Error GoTo 0
    Next n
    For n = 1 To coll.Count
        Set Wbk = Workbooks.Add(1)
        Set Sht = Wbk.Sheets(1)
            Sht.Name = coll(n)
            .Range("A1").AutoFilter field:=1, Criteria1:=coll(n)
            .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sht.Range("A1")
            .Range("A1").AutoFilter
            Wbk.SaveAs Dossier & coll(n)
            Wbk.Close
        Set Sht = Nothing
        Set Wbk = Nothing
    Next n
End With
Set aSht = Nothing
Set tWbk = Nothing
End Sub

Attention, il faut quand même gérer le cas où l'un des fichiers fils est déjà ouvert.
Edit
Pour fermer les classeurs fils ouverts

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
Sub decoupage()
Dim tWbk As Workbook, Wbk As Workbook
Dim aSht As Worksheet, Sht As Worksheet
Dim Dossier As String
Dim coll As New Collection
Dim LastLig As Long, n As Long
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Set tWbk = ThisWorkbook
Dossier = tWbk.path & "\"
Set aSht = tWbk.ActiveSheet
With aSht
    LastLig = .Cells(Rows.Count, "A").End(xlUp).Row
    For n = 2 To LastLig
    On Error Resume Next
        coll.Add .Range("A" & n).Value, CStr(.Range("A" & n).Value)
    On Error GoTo 0
    Next n
    For n = 1 To coll.Count
        For Each Wbk In Workbooks
            If Wbk.Name = coll(n) & ".xls" Then
                Wbk.Close False
                Exit For
            End If
        Next Wbk
        Set Wbk = Workbooks.Add(1)
        Set Sht = Wbk.Sheets(1)
            Sht.Name = coll(n)
            .Range("A1").AutoFilter field:=1, Criteria1:=coll(n)
            .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sht.Range("A1")
            .Range("A1").AutoFilter
            Wbk.SaveAs Dossier & coll(n)
            Wbk.Close
        Set Sht = Nothing
        Set Wbk = Nothing
    Next n
End With
Set aSht = Nothing
Set tWbk = Nothing
End Sub

[Bernard67]

Merci mercatog,
mais j'ai la meme erreur qu'avec mon code.

Exécution interrompue" et surlignage du code

Code :

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

Wbk.Close

Je joins le fichier, au cas ou ........

[patricktoulon]

bonjour


tu utilise la variable wbk pour

Set Wbk = Workbooks.Add


donc wbk c'est une variable d'ajout de classeur et non pas un classeur

si tu veux t en sortir il faudrai que tu donne un nom a ce nouveau classeur

et si possible dans une variables string

et a la fin

windows(nomque tu lui a donné ).activate
windows(nomque tu lui a donné ).close

[Bernard67]

Bonjour le forum,

J'ai adapter une macro de pierrejean, mais par contre il y a un problème que je n'arrive pas à résoudre.
Lors de la copie dans les onglets, je souhaiterais que la largeur des colonnes s'adapte aux données contenues.

Voici la macro de pierrejean

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
Sub test()
'1ere etape
'lister les noms des villes sans doublons
Dim villes As Collection
Set villes = New Collection
For n = 3 To Range("A65536").End(xlUp).Row
  On Error Resume Next
    villes.Add Range("A" & n)
  On Error GoTo 0
Next n
'2eme etape
'créer les feuilles correspondantes aux noms de ville
For n = 1 To villes.Count
'tester si la feuille existe
 For m = 1 To Sheets.Count
   If Sheets(m).Name = villes(n) Then
    exist = True
    Exit For
    End If
 Next m
' si elle n'existe pas la creer
 If Not exist Then
   Sheets.Add.Name = villes(n)
'en profiter pour initialiser l'en-tete
   Sheets("Feuil1").Range("A2:F2").Copy Destination:=ActiveSheet.Range("A2")
 End If
 'reinitialiser le flag exist
 exist = False
Next n
'derniere etape transferer les données
For n = 3 To Sheets("Feuil1").Range("A65536").End(xlUp).Row
'reperage de la feuille ou copier
  feuil = Sheets("Feuil1").Range("A" & n)
'chercher la derniere ligne et se placer a la suite
  fin = Sheets(feuil).Range("A65536").End(xlUp).Offset(1, 0).Address
'copier les celules de A a F
  Sheets("Feuil1").Range("A" & n & ":F" & n).Copy Destination:=Sheets(feuil).Range(fin)
Next n
 
End Sub

Merci pour l'aide et bonne journée