Convertir une zone d'une feuille d'un fichier Excel en CSV
Bonjour ! Je vous explique la situation, j'ai un fichier Excel, une feuille avec les données (Feuil1) et une feuille avec le bouton d'une macron (Feuil2), ce que je veux c'est que quand j'active le bouton, cela crée un nouveau fichier CSV avec les données de la Feuil1, comment faire ?
J'ai déjà ce code, mais ce code selectionne un fichier Excel qu'on choisit et le convertit en CSV (en créant un nouveau fichier CSV)
Sub Main()
Dim fileToConvertInCSV As String
Dim fileToConvertInUTF8 As String
Dim Result
Do Until Result = vbNo
fileToConvertInCSV = FileSelected
fileToConvertInUTF8 = CSVConverted(fileToConvertInCSV)
Call WriteANSItoUF8WithoutBOM(fileToConvertInUTF8, fileToConvertInUTF8)
Result = MsgBox("Do you want to select another file ?", vbQuestion + vbYesNo)
Loop
'améliorations à implémenter
'File Selected => n'autoriser que la sélection Excel
'ConvertUTF8 => convertir en UTF8 sans N
End Sub
Function FileSelected() As String
'Function to Open a file
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx?,*.xls?,*.xlsb?,*.xlsm?", 1
.Title = "Choose an Excel file"
.AllowMultiSelect = False
If .Show = True Then
FileSelected = .SelectedItems(1)
End If
End With
End Function
Function CSVConverted(fileToConvert As String) As String
Dim toConvertFile As String
Dim convertedFile As String
Dim Rows As Long
Dim Cols As Long
Dim J As Long
Dim K As Long
Dim sTemp As String
Dim sSep As String
Dim wb As Workbook
Const adCrLf As Long = -1
Const adModeUnknown As Long = 0
Const adSaveCreateOverWrite As Long = 2
Const adTypeText As Long = 2
sSep = ";!@#;" 'Specify the separator to be used
toConvertFile = fileToConvert
Workbooks.Open toConvertFile
Sheets(1).Activate
Dim fileExtension As String
fileExtension = Right(toConvertFile, Len(toConvertFile) - InStrRev(toConvertFile, "."))
If fileExtension = "xlsm" Or fileExtension = "xlsx" Or fileExtension = ".xlsb" Or fileExtension = ".xls" Then
toConvertFile = Mid(toConvertFile, 1, Len(toConvertFile) - Len(fileExtension))
convertedFile = toConvertFile & ".csv"
Open convertedFile For Output As 1
With ActiveSheet
'Number of rows to export is based on the contents
'of column J. If it should be based on a different
'column, change the following line to reflect the
'column desired.
Rows = .Cells(.Rows.Count, "J").End(xlUp).Row
For J = 1 To Rows
sTemp = ""
Cols = .Cells(J, .Columns.Count).End(xlToLeft).Column
For K = 1 To Cols
sTemp = sTemp & .Cells(J, K).Value
If K < Cols Then sTemp = sTemp & sSep
Next
Print #1, sTemp
Next J
End With
Close 1
sTemp = "There were " & Rows & " rows of data written "
sTemp = sTemp & "to this file:" & vbCrLf & toConvertFile
Else
sTemp = "This macro needs to be run on a workbook "
sTemp = sTemp & "stored in the XLSX, XLSM, XLSB or XLS format."
End If
ActiveWorkbook.Close
'Dim wbName As String
'wbName = Right(toConvertFile, Len(toConvertFile) - InStrRev(toConvertFile, "\"))
'For Each wb In Workbooks
' If wb.Name = wbName Then
' Workbooks.Close wbName
' Exit Sub
' End If
'Next
MsgBox sTemp
CSVConverted = convertedFile
End Function
Merci d'avance de votre aide !
Bonjour
Voila qui devrait faire l'affaire
Sub ExportCSV()
Dim nomFichier As String
nomFichier = "nom du nouveau fichier.csv"
ThisWorkbook.Worksheets("nom de la feuille").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Bonjour, j'aime bien ce code, mais comment faire pour que le nouveau fichier CSV dans dans le même chemin que le fichier de base ?
sachant que le fichier de base on connait pas forcement le chemin
Donc peut-être spécifier "ThisWorkbooks.Path"
Public Sub ExportWorksheetAndSaveAsCSV()
Dim wbkExport As Workbook
Dim shtToExport As Worksheet
Dim Path As String
Dim FileName As String
Set shtToExport = ThisWorkbook.Worksheets("Deliveries") 'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
Path = ThisWorkbook.Path
FileName = "test"
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite without asking
wbkExport.SaveAs FileName:=Path & FileName & ".csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False
End Sub
J'ai tenté un truc mais ça me retourne rien ...
Sub ExportCSV()
Dim nomFichier As String
Dim chemin As String
chemin = ThisWorkbook.Path & "\"
nomFichier = chemin & "test.csv"
ThisWorkbook.Worksheets("élèves").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Merci beaucoup mais il faudrait juste un dernier petit détail, enfaite ça me retourne un fichier CSV mais avec encodage ANSI, or je veux encodage UTF-8
J'ai ce code qui transforme un ANSI en UTF-8
Sub WriteANSItoUF8WithoutBOM(fileToConvert, fileToSave As String)
Dim fileToConvertPath, fileToSavePath As String
fileToConvertPath = fileToConvert
fileToSavePath = fileToSave
Set UTFStream = CreateObject("adodb.stream")
Set ANSIStream = CreateObject("adodb.stream")
Set BinaryStream = CreateObject("adodb.stream")
ANSIStream.Type = adTypeText
ANSIStream.Mode = adModeReadWrite
ANSIStream.Charset = "iso-8859-1"
ANSIStream.Open
ANSIStream.LoadFromFile fileToConvertPath 'ANSI File
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
ANSIStream.CopyTo UTFStream
UTFStream.Position = 3 'skip BOM
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
'Strips BOM (first 3 bytes)
UTFStream.CopyTo BinaryStream
BinaryStream.SaveToFile fileToSavePath, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
End Sub
Mais comment je fais pour le faire avec mon code de base ?
Sub Main()
Dim fileToConvertInUTF8 As String
fileToConvertInUTF8 = ExportCSV()
Call WriteANSItoUF8WithoutBOM(fileToConvertInUTF8, fileToConvertInUTF8)
End Sub
Sub ExportCSV()
Dim nomFichier As String
Dim chemin As String
Dim convertedFile As String
chemin = ThisWorkbook.Path & "\"
nomFichier = chemin & "test.csv"
ThisWorkbook.Worksheets("Deliveries").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=nomFichier, FileFormat:=xlCSV, local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
JE tente ça mais ça marche pas, ça me met Fonction ou Variable attendu ...;
Après quelques recherches voila qui semble faire le job
Sub ExportCSV()
Dim nomFichier As String
Dim chemin As String
chemin = ThisWorkbook.Path & "\"
nomFichier = chemin & "test.csv"
ThisWorkbook.Worksheets("élèves").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Dim sInFilePath As String
Dim sOutFilePath As String
sInFilePath = nomFichier
sOutFilePath = nomFichier
Call convertTxttoUTF(sInFilePath, sOutFilePath)
End Sub
Sub convertTxttoUTF(sInFilePath As String, sOutFilePath As String)
Dim objFS As Object
Dim iFile As Double
Dim sFileData As String
'Init
iFile = FreeFile
Open sInFilePath For Input As #iFile
sFileData = Input$(LOF(iFile), iFile)
sFileData = sFileData & vbCrLf
Close iFile
'Open & Write
Set objFS = CreateObject("ADODB.Stream")
objFS.Charset = "utf-8"
objFS.Open
objFS.WriteText sFileData
'Save & Close
objFS.SaveToFile sOutFilePath, 2 '2: Create Or Update
objFS.Close
'Completed
Application.StatusBar = "Completed"
End Sub
Yes, merci beaucoup !
Mieux encore au niveau de l'encodage
Option Explicit
Sub ExportCSV()
Dim nomFichier As String
Dim chemin As String
chemin = ThisWorkbook.Path & "\"
nomFichier = chemin & "test.csv"
ThisWorkbook.Worksheets("élèves").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Dim nmF$
nmF = chemin & "test.csv"
Call WriteANSItoUF8WithoutBOM(nomFichier)
End Sub
Sub WriteANSItoUF8WithoutBOM(nomFichier As String)
Dim UTFStream As New ADODB.Stream
Dim ANSIStream As New ADODB.Stream
Dim BinaryStream As New ADODB.Stream
ANSIStream.Type = adTypeText
ANSIStream.Mode = adModeReadWrite
ANSIStream.Charset = "iso-8859-1"
ANSIStream.Open
ANSIStream.LoadFromFile nomFichier
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
ANSIStream.CopyTo UTFStream
UTFStream.Position = 3 'skip BOM
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
'Strips BOM (first 3 bytes)
UTFStream.CopyTo BinaryStream
BinaryStream.SaveToFile nomFichier, 2
BinaryStream.Flush
BinaryStream.Close
End Sub