Probleme sur macro qui eclate un fichier

**Bernard67** · 07/07/2010, 15h29

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** · 07/07/2010, 15h39

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** · 07/07/2010, 16h06

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** · 07/07/2010, 16h51

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** · 07/07/2010, 17h17

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** · 07/07/2010, 18h06

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** · 08/07/2010, 09h38

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

**zyhack** · 08/07/2010, 10h16

Bonjour

en fin de code après cette ligne

Code :

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

Sheets("Feuil1").Range("A" & n & ":F" & n).Copy Destination:=Sheets(feuil).Range(Fin)

ajoute celle là

Code :

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

Sheets("Feuil1").Cells.EntireColumn.AutoFit

ça devrait faire ton bonheur

**mercatog** · 08/07/2010, 10h24

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

non no wbk est bien un classeur
J'ai testé le code fourni précédemment sur ton fichier joint et a fonctionné (en adaptant le nom de feuille)

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
Option Explicit
Public 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.Sheets("QUICK")
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** · 08/07/2010, 10h25

Merci zyhack,
Mais le probleme persiste car cela agrandi les colonnes de la base source, mais pas celles des onglets ou sont recopiées les données.
Merci pour le coup de main

**zyhack** · 08/07/2010, 11h27

Bonjour

un peu de reflexion voyon, il n'y a que le moment ou le nom de la feuille à changer dans la solution que je t'ai donné

essaye en remplaçant

Code :

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

 Sheets("Feuil1").Cells.EntireColumn.AutoFit

par

Code :

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

Sheets(feuil).Cells.EntireColumn.AutoFit

dans tous les cas, aprés la ligne qui effectue la copie

Code :

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

Sheets(nom de la feuille).Cells.EntireColumn.AutoFit

**Bernard67** · 08/07/2010, 14h09

Merci zyhack, le forum
Les problèmes sont réglés
Bon AM
Cordialement

Probleme sur macro qui eclate un fichier [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager