Discussion :

[docofchaos]

Bonjour,

Je me retourne vers vous pour axée ma recherche pour une macro.

Actuellement, j'ai des fichier .xls, pour faciliter la migration sur des fichiers en .xlsx j'ai recupéré et adapté une macro déjà existante.
Seul probléme, c'est que cette macro garde l'ancien fichier. Je voudrais le supprimer une fois qu'il a enregistré ma feuille dans le nouveau format.

J'ai essayer de faire une comparaison entre les deux extensions, mais quand la macro arrive sur le xlsx, il le considére comme un fixhier xls.

Si quelqu'un a une idé pour gerer les conditions je prend.

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
 
Dim Nb As Long
Const sExtension As String = "xls"
Const sNewExtension As String = "xlsx"
Const TypeFichier = "xls"
 
Public Sub ChangerExtensionFichiers(ByVal sDossier As String, bSousDossier As Boolean)
 
 
Dim FSO As Object
Dim Dossier As Object
Dim sFichier As String, F As String
Dim Pos As Long, i As Long, sExt As String
Dim TFichier() As String
Dim sNom As String
 
    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sDossier)
 
    TFichier = Split(TypeFichier, ";")
 
    sFichier = Dir$(sDossier & "\*.*")
 
    Do While Len(sFichier) > 0
        F = FSO.GetFileName(sFichier)
        For i = LBound(TFichier) To UBound(TFichier)
            If UCase(sFichier) <> UCase(ThisWorkbook.Name) Then
                Pos = InStr(F, TFichier(i))
                sExt = FSO.GetExtensionName(F)
                If Pos > 0 And UCase(sExt) = UCase(sExtension) Then
                    sNom = Left$(F, Len(F) - Len(sExt))
 
                    Workbooks.Open Filename:=sDossier & "\" & sFichier
                    Application.DisplayAlerts = False
                    ActiveWorkbook.SaveAs Filename:=sDossier & "\" & sNom & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True
 
                    Nb = Nb + 1
                End If
 
 
Set FSO1 = CreateObject("Scripting.FileSystemObject")
    Set fi = FSO1.GetFolder(Dossier)
    Set fc = FS01.GetFileName(sFichier)
 
 
   For Each fi In fc
       If (fc.GetExtensionName = sExtension) Then
        Set FS = CreateObject("Scripting.FileSystemObject")
        FS.DeleteFile fi, True
 
       If (fc.GetExtensionName = sNewExtension) Then
       End
       End If
 
       End If
    Next
 
 
 
 
 
            End If
        Next i
        sFichier = Dir$()
        Application.StatusBar = Nb
    Loop
 
 
 
 
 
 
 
 
End Sub
 
Sub SelDossier()
Dim sStr As String
    sStr = Replace(TypeFichier, ";", "   ")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Changement Extension fichiers ( " & sStr & " ) de " & UCase(sExtension) & " en " & UCase(sNewExtension)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        Nb = 0
        If .SelectedItems.Count > 0 Then
            DoEvents
            ChangerExtensionFichiers .SelectedItems(1), True
 
        End If
 
 
    End With
 
 
 
End Sub

merci d'avance doc'

[docofchaos]

Je viens de trouver comment faire, je post donc la macro si quelqu'un a besoin

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
 
Dim Nb As Long
Const sExtension As String = "xls"
Const sNewExtension As String = "xlsx"
Const TypeFichier = "xls"
 
Public Sub ChangerExtensionFichiers(ByVal sDossier As String, bSousDossier As Boolean)
 
 
Dim FSO As Object
Dim Dossier As Object
Dim sFichier As String, F As String
Dim Pos As Long, i As Long, sExt As String
Dim TFichier() As String
Dim sNom As String
 
    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sDossier)
 
    TFichier = Split(TypeFichier, ";")
 
    sFichier = Dir$(sDossier & "\*.*")
 
    Do While Len(sFichier) > 0
        F = FSO.getfileName(sFichier)
        For i = LBound(TFichier) To UBound(TFichier)
            If UCase(sFichier) <> UCase(ThisWorkbook.Name) Then
                Pos = InStr(F, TFichier(i))
                sExt = FSO.GetExtensionName(F)
                If Pos > 0 And UCase(sExt) = UCase(sExtension) Then
                    sNom = Left$(F, Len(F) - Len(sExt))
 
                    Workbooks.Open Filename:=sDossier & "\" & sFichier
                    Application.DisplayAlerts = False
                    ActiveWorkbook.SaveAs Filename:=sDossier & "\" & sNom & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True
 
                    Nb = Nb + 1
 
 
 
 
 
    Set fs01 = CreateObject("Scripting.FileSystemObject")
    Set Fi = fs01.GetFolder(Dossier)
    Set Fc = fs01.getfile(Dossier & "\" & sNom & sExtension)
 
    If fs01.FileExists(Fc) Then
        Set FS = CreateObject("Scripting.FileSystemObject")
       FS.DeleteFile Fc, True
    End If
 
       End If
 
 
 
            End If
        Next i
        sFichier = Dir$()
        Application.StatusBar = Nb
    Loop
 
 
 
 
 
 
 
 
End Sub
 
Sub SelDossier()
Dim sStr As String
    sStr = Replace(TypeFichier, ";", "   ")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Changement Extension fichiers ( " & sStr & " ) de " & UCase(sExtension) & " en " & UCase(sNewExtension)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        Nb = 0
        If .SelectedItems.Count > 0 Then
            DoEvents
            ChangerExtensionFichiers .SelectedItems(1), True
 
        End If
 
 
    End With
 
 
 
End Sub