Crée macro pour enregistrer en fichier .csv

[jonki]

Bonjour, je suis un débutant en macro vb excel et je cherche à faire plusieurs choses...

En effet, je voudrais pouvoir crée une macro excel qui m'enregistre un fichier xls en csv, il doit aussi ajouter une colonne au début et supprimer les accents et espace de ma première ligne.

Pour enregistrer en csv, j'ai un peu magouiller et j'arrive à faire cela :

 Sub SaveAsCSV()
Dim Range As Object, Line As Object, Cell As Object
' Définition de la conversion
 
Dim StrTemp As String
Dim Separateur As String
Dim Nom As String, Rep
  With ActiveWorkbook
    Nom = .Name
    If .Path <> "" Then Nom = Left$(Nom, InStr(1, Nom, ".") - 1)
  End With
  Rep = Application.GetSaveAsFilename(Nom, "Fichier CSV,*.csv")
    Separateur = ";"
 
    Set Range = ActiveSheet.UsedRange
    Open Rep For Output As #1
 
    For Each Line In Range.Rows
        sansAccents (A1)
        StrTemp = ""
        For Each Cell In Line.Cells
 
            StrTemp = StrTemp & CStr _
                (Cell.Text) & Separateur
 
        Next
        Print #1, StrTemp
    Next
    
    Close
 
 

Mais je n'arrive pas à insérer une colonne en A1 en écrivant quelquechose (par exemple "test") avant de convertir, et j'ai également des soucis pour la correction des accents même si j'ai trouvé quelque chose:

 
  Const accent As String = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç"
    Const noAccent As String = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc"
    
     ' La fonction :
     
     Private Function sansAccents(ByRef s As String) As String
     Dim i As Integer
     Dim lettre As String * 1
     sansAccents = s
     For i = 1 To Len(accent)
     lettre = Mid$(accent, i, 1)
     If InStr(sansAccents, lettre) > 0 Then
     sansAccents = Replace(sansAccents, lettre, Mid$(noAccent, i, 1))
     End If
     Next i
     End Function
 
 

Mais je ne vois pas trés bien comment appliquer tout cela en une et une seule macro... si quelqu'un pourrait m'éclairer..

je vous remercie d'avance

bonne journée

[tirex28]

Bonjour,

Vois si ceci te convient:

Sub SaveCSV()
    Dim Plage As Range, Cell As Range
    Set Plage = Range("A1").CurrentRegion
 
    'il doit aussi ajouter une colonne au début
    Range("A:A").Insert xlShiftToRight
 
    'Mais je n'arrive pas à insérer une colonne en A1 en écrivant quelquechose
    '(par exemple "test") avant de convertir
    Plage.Columns(1).Offset(0, -1).Value = "Test"
 
    For Each Cell In Plage.Rows(1).Cells 'Parcours la ligne de titre
        'et j'ai également des soucis pour la correction des accents
        'même si j'ai trouvé quelque chose:
        Cell.Value = SuppAccentsEspace(Cell.Value)
    Next
 
    'enregistre la feuille au format csv dans le repertoire courant
    Dim Sh As Worksheet
    Set Sh = ActiveSheet
    Sh.SaveAs Sh.Name, xlCSV
 
End Sub

 
Function SuppAccentsEspace(chaine As String) As String
    'Les espaces sont remplaces par "_"
    Const noAccent As String = "AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc_"
    Const accent As String = "ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç "
    Dim i As Long, z As Long
    For i = 1 To Len(chaine)
        z = InStr(1, accent, Mid(chaine, i, 1))
        If z > 0 Then Mid(chaine, i, 1) = Mid(noAccent, z, 1)
    Next
    SuppAccentsEspace = chaine
End Function

Cordialement,

Tirex28/

[jonki]

Merci Tirex28, c'est tout bon, j'ai juste effectuer quelques modifications sur l'enregistrement, mais autrement tu m'as bien aidé, merci beaucoup, bonne journée

jonki