Bonjour,

Je suis bloquée dans ma macro: je n'ai pas de messages d'erreur, mais elle ne me donne pas ce que je voudrais avoir:
Dans mon fichier BD, ma colonne 22 est triée par ordre alphabétique. Ainsi, cette colonne contient disons des noms de ville. J'aimerais créer pour chaque nom de ville différent un fichier portant le nom de la ville et contenant les lignes correspondantes à ces villes.

Je crée pour cela un fichier intermédiaire "PTF.xls" qui importe d'abord les lignes par ville, que je sauve ensuite sous le nom de la ville en question et que je vide ensuite.

Malheureusement, pour le moment, ma macro n'a réussi qu'à créer le fichier PTF en y copiant tout mon tableau BD (toutes villes confondues).

Merci d'avance pour votre aide!

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
 
Sub Creation_classeurs_PTF()
On Error Resume Next
 
Dim i As Integer
Dim j As Integer
Dim LastLig As Long
Dim x As Double
Dim BD As String
Dim PTF1 As String
Dim wbk As Workbook
Dim ret As Variant
 
Application.ScreenUpdating = False
BD = "S:\XXX\abcd.xls"
 
Set wbk = Workbooks.Open(BD)
 
LastLig = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(1, 1), Cells(LastLig, 40)).Select
Selection.Sort Key1:=Range("V1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
'Supprime le fichier PTF s'il existe
ret = Dir("S:\XXX\PTF.xls", vbHidden)
If ret <> "" Then
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile("S:\XXX\PTF.xls") 
    f.Delete
End If
 
For i = 2 To LastLig
    If Cells(i, 22).Value = Cells(i - 1, 22).Value Then
    Set PTF = Workbooks.Open(PTF1)
    wbk.Sheets(1).Rows(i).Copy PTF.Sheets(1).Cells(i, 1)
    PTF.Close SaveChanges:=True
 
    Else:
        If ret <> "" Then
        PTF1 = "S:\XXX\PTF.xls"
        Set PTF = Workbooks.Open(PTF1)
        PTF.SaveCopyAs Filename:="S:\XXX\" & Cells(i, 22) & ".xls"
        PTF.Sheets(1).Cells.ClearContents
        PTF.Close SaveChanges:=True
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set f = fs.GetFile("S:\XXX\PTF.xls")    
        f.Delete
        End If
    Set NewPTF = Workbooks.Add
    NewPTF.SaveCopyAs "S:\XXX\PTF.xls"
    PTF1 = "S:\XXX\PTF.xls"
    Set PTF = Workbooks.Open(PTF1)
    wbk.Sheets(1).Rows(i).Copy PTF.Sheets(1).Cells(i, 1)
    PTF.Close SaveChanges:=True
 
    End If
Next i
 
wbk.Close SaveChanges:=False
Application.ScreenUpdating = True
 
On Error GoTo 0
End Sub