Exporter feuille excel en xlsx OU csv

Version imprimable

Bonjour à tous,

J'ai un fichier Excel avec 4 feuilles et une macro qui me permet d'exporter uniquement la première feuille.
Cette feuille s'enregistre donc par défaut en fichier .xlsx

Seulement, j'ai besoin que, si besoin, on puisse choisir au moment de l'enregistrement, si on veut l'exporter en fichier Excel (.xlsx) ou en fichier .csv

Est-ce possible ?

Voici le code de ma macro :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Dim Sh1 As Worksheet Set Sh1 = ThisWorkbook.Worksheets(1) Titre = "Enregistrer le fichier sous" Chemin = Application.GetSaveAsFilename(FichierFinal, Filtre, , Titre) If Chemin = False Then Exit Sub Else Sh1.Copy If Chemin <> "" Then ActiveWorkbook.SaveAs Filename:=Chemin Else MsgBox "Fichier non enregistré" End If End If
Merci d'avance ! :)

Citation:

Envoyé par jeannevds

Bonjour,

Un exemple à adapter avec une boite de dialogue :
Pièce jointe 403878

Dans un module standard :

Code:

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
 
Option Explicit
 
Sub LancerLaBoiteDeDialogue()
 
    ChDir ActiveWorkbook.Path
 
    With UsfSauvegarde
 
         .Show
 
    End With
 
End Sub
 
 
Sub ExporterLaFeuille1(ByVal Chemin As String, FichierFinal As String, ByVal TypeSauvegarde As String)
 
 Dim WbCree As Workbook
 Dim ShCreee As Worksheet
 
 Dim DerniereLigne As Long, LigneEnCours As Long
 Dim NbShapes As Integer
 
    Sheets(1).Copy
    Set WbCree = ActiveWorkbook
    Set ShCreee = WbCree.Sheets(1)
 
    With ShCreee
 
         If .Shapes.Count > 0 Then
            For NbShapes = .Shapes.Count To 1 Step -1
                .Shapes(NbShapes).Delete
            Next NbShapes
         End If
 
         DerniereLigne = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         For LigneEnCours = DerniereLigne To 1 Step -1
             If WorksheetFunction.CountA(.Rows(LigneEnCours)) = 0 Then .Rows(LigneEnCours).Delete
         Next LigneEnCours
 
    End With
 
    Application.DisplayAlerts = False
    With WbCree
         Select Case TypeSauvegarde
                Case "Csv"
                     .SaveAs Filename:=Chemin & "\" & FichierFinal & ".csv", FileFormat:=xlCSV, CreateBackup:=False, Local:=True
                     .Close SaveChanges:=False  ' Important False pour avoir le ; comme séparateur de champ, ne pas changer.
                Case "Xlsx"
                    .SaveAs Filename:=Chemin & "\" & FichierFinal & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=True
                     .Close SaveChanges:=True
        End Select
    End With
    Application.DisplayAlerts = True
 
    GoTo Fin
 
Fin:
 
    Set ShCreee = Nothing
    Set WbCree = Nothing
 
 
End Sub

Dans la boite de dialogue :

Code:

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
 
Option Explicit
 
Private Sub BoutonFusionRepertoire_Click()
 
Dim Fd As FileDialog
Dim vrtSelectedItem As Variant
 
    Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
    With Fd
        If .Show = -1 Then
            For Each vrtSelectedItem In .SelectedItems
                TextBoxRepertoire = vrtSelectedItem
            Next vrtSelectedItem
        End If
    End With
 
    Set Fd = Nothing
 
End Sub
 
 
Private Sub BoutonRetour_Click()
 
     Unload UsfSauvegarde
 
End Sub
 
Private Sub BoutonValider_Click()
 
Dim MesMessages As String
 
    On Error GoTo FinValidation
 
    MesMessages = ""
    If TextBoxRepertoire = "" Then MesMessages = "Absence répertoire." & Chr(10)
    If TextBoxFichier = "" Then MesMessages = MesMessages & Chr(10) & "Absence nom de fichier."
 
    If MesMessages <> "" Then
       MsgBox MesMessages
       GoTo FinValidation
    End If
 
 
    If Me.OptionXlsx = True Then
        ExporterLaFeuille1 TextBoxRepertoire, TextBoxFichier, "Xlsx"
    Else
       ExporterLaFeuille1 TextBoxRepertoire, TextBoxFichier, "Csv"
    End If
 
    GoTo FinValidation
 
 
FinValidation:
 
 
End Sub

Citation:

Envoyé par jeannevds

Une variante s'il faut repérer la ligne de titre et supprimer toutes les lignes avant dans l'export :

Code:

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
 
Option Explicit
 
 
Sub ExporterLaFeuille1V2(ByVal Chemin As String, FichierFinal As String, ByVal TypeSauvegarde As String)
 
 Dim WbCree As Workbook
 Dim ShCreee As Worksheet
 
 Dim DerniereLigne As Long, LigneEnCours As Long, LigneDeTitre As Long
 Dim NbShapes As Integer
 
    Sheets(1).Copy
    Set WbCree = ActiveWorkbook
    Set ShCreee = WbCree.Sheets(1)
 
    With ShCreee
 
         If .Shapes.Count > 0 Then
            For NbShapes = .Shapes.Count To 1 Step -1
                .Shapes(NbShapes).Delete
            Next NbShapes
         End If
 
         DerniereLigne = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         For LigneEnCours = DerniereLigne To 1 Step -1
             If WorksheetFunction.CountA(.Rows(LigneEnCours)) = 0 Then .Rows(LigneEnCours).Delete
         Next LigneEnCours
 
         LigneDeTitre = LigneDeTitreTrouvee(ShCreee, Array("Id", "Nom", "Prénom"), 100)
 
         Select Case LigneDeTitre
                Case 0
                     WbCree.Close savechanges:=False
                     MsgBox "Ligne de titre non trouvée !", vbCritical
                     GoTo Fin
              Case Is > 1
                    .Rows("1:" & LigneDeTitre - 1).Delete Shift:=xlUp
         End Select
 
 
    End With
 
    Application.DisplayAlerts = False
    With WbCree
         Select Case TypeSauvegarde
                Case "Csv"
                     .SaveAs Filename:=Chemin & "\" & FichierFinal & ".csv", FileFormat:=xlCSV, CreateBackup:=False, Local:=True
                     .Close savechanges:=False  ' Important False pour avoir le ; comme séparateur de champ, ne pas changer.
                Case "Xlsx"
                    .SaveAs Filename:=Chemin & "\" & FichierFinal & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=True
                     .Close savechanges:=True
        End Select
    End With
    Application.DisplayAlerts = True
 
    GoTo Fin
 
Fin:
 
    Set ShCreee = Nothing
    Set WbCree = Nothing
 
 
End Sub
 
 
 
 
Function LigneDeTitreTrouvee(ByVal FeuilleTestee As Worksheet, ByVal LibellesATester As Variant, ByVal NombreDeLignesTestees As Long) As Long
 
Dim CompteurDeLignes As Long
Dim CompteurDeColonnes As Long
Dim CompteurDeLibelles As Long
Dim NbChaines As Long
 
    With FeuilleTestee
         LigneDeTitreTrouvee = 0
         If .UsedRange.Rows.Count > 0 Then
            For CompteurDeLignes = .UsedRange.Row To .UsedRange.Row + NombreDeLignesTestees - 1
                NbChaines = 0
                For CompteurDeLibelles = LBound(LibellesATester) To UBound(LibellesATester)
                    If WorksheetFunction.CountA(.Rows(CompteurDeLignes)) > 0 Then
                       For CompteurDeColonnes = .UsedRange.Column To .Columns.Count
                           If CStr(.Cells(CompteurDeLignes, CompteurDeColonnes)) = LibellesATester(CompteurDeLibelles) Then NbChaines = NbChaines + 1
                       Next CompteurDeColonnes
                    End If
                Next CompteurDeLibelles
                If NbChaines = UBound(LibellesATester) + 1 Then
                   LigneDeTitreTrouvee = CompteurDeLignes
                   Exit Function
                End If
            Next CompteurDeLignes
         End If
    End With
 
End Function