Export onglets en csv avec tabulation

Version imprimable

Bonjour à tous,
Merci de m'accueillir sur votre forum.
Avant toute chose, je souhaitais vous remercier pour les nombreuses solutions que j'ai pu trouver sur le forum avant mon inscription.
Je souhaite aujourd'hui créer une macro que me permet d'exporter tous les onglets d'un classeur en fichiers csv (avec séparateur tabulation) du m^me nom que l'onglet.
J'ai un début de solution qui fonctionne très bien mais qui me génère des fichier "xls" (macro ci-dessous)
Merci par avance à la personne qui pourra prendre un peu de son temps pour m'aider!
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub export() Dim ws Dim newWk As Workbook For Each ws In Worksheets Set newWk = Workbooks.Add(xlWBATWorksheet) ws.Copy newWk.Sheets(1) newWk.SaveAs (ws.Name & ".xls") newWk.Close Set newWk = Nothing Next ws End Sub

30/08/2017, 12h37
unparia

Bonjour
Ce qui revient à enregistrer au format txt.
Et un tel code s'obtient (et est donc connu) par utilisation toute bête de l'enregistreur de macros .

Bonjour
sinon si tu avais Bien cherché des exemples tu en aurais trouvé a profusion
apres des méthodes tu en trouvera pas mal aussi
dans les contribs j'en ai fait une qui n'utilise pas les chemin classique mais intéressante tout de meme
il se trouve que la récuperation dans le clipboard de la copy d'une plage est déjà toute formatée comme tu le souhaite

parti de la avec l'utilisation de la fonction open for input de vba il est facile de créer un fichier text

démonstration
ici je copie juste la plage utilisée de chaque sheets et cette plage est sauvée dans un fichier text sous le nom du sheets

Sub de test

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub test()
    Dim plage As Range, EXT As String, chemin As String, nom As String
        For i = 1 To Sheets.Count
    Set plage = Sheets(i).Range("A1").CurrentRegion
    chemin = "C:\Users\" & Environ("username") & "\Desktop\"
    nom = Sheets(i).Name
    EXT = ".csv"
    RangeToFichierTexT plage, chemin, nom
Next
MsgBox "sauvegarde des sheets en CSV terminée"
End Sub

et la fonction qui fait le boulot

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Function RangeToFichierTexT(Rng, Optional chemin As String = "", Optional nom As String = "", Optional EXT As String = ".csv")
    Dim T, clearall, fichier As String
    If chemin = "" Then chemin = "C:\Users\" & Environ("username") & "\Desktop\"
    If nom = "" Then nom = Rng.Parent.Name & "-" & Replace(Rng.Address, ":", "-")
    With CreateObject("htmlfile")
        clearall = .parentwindow.clipboardData.setData("Text", "")    'on vide le clipboard au cas ou il y aurait quelque chose
        Rng.Copy    'on copy la plage tout simplement
          T = .parentwindow.clipboardData.GetData("TEXT")' on récupère la plage en texte 
        Application.CutCopyMode = False    'on relâche la plage copiée
    'on créé le ficher avec open for....
    End With
    fichier = chemin & nom & EXT
    x = FreeFile
    Open fichier For Output As #x
    Print #x, T
    Close #x
End Function

Bonjour Patrick, unparia et felix-o,

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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#If VBA7 Then Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As Long
 Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
 Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#Else
 Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
 Private Declare Function CloseClipboard Lib "User32" () As Long
 Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
 Private Declare Function EmptyClipboard Lib "User32" () As Long
 Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#End If
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
 
Sub test()
Dim txt As String, Fichier As String
Fichier = Split(ThisWorkbook.FullName, ".xls")(0) & ".CSV"
ActiveSheet.UsedRange.Copy
txt = ClipBoard_GetData
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(Fichier) = True Then fso.DeleteFile Fichier, True
Set NewFichier = fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
 
End Sub
Function ClipBoard_GetData() As String
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)
 
   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
 
   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
 
   ' Clear the Clipboard.
   X = EmptyClipboard()
 
   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 
   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If
 
   End Function

30/08/2017, 13h33
felix-o

Bonjour à tous et merci!
Patrick, si j'ai bien compris, j'ai deux macro à lancer?
30/08/2017, 13h57
Menhir
Citation:

Envoyé par felix-o

exporter tous les onglets d'un classeur en fichiers csv (avec séparateur tabulation) du m^me nom que l'onglet.

CSV signifie Comma Separated Values (valeurs séparées par des virgules).
Donc, par définition, un fichier avec Tab comme séparateur ne peut pas être un CSV.

Pour régler ton problème, je propose une solution plus simple que celles de mes camarades : l'utilisation de la méthode Worksheet.SaveAs :
https://msdn.microsoft.com/fr-fr/lib.../ff195820.aspx
Code:

1 2 3 4 Dim ws For Each ws In Worksheets ws.SaveAs "C:\Mon_chemin\" & ws.Name & ".csv", FileFormat:=xlTextWindows Next ws
Ca crée un fichier ne contenant les données que le la feuille spécifiée séparées par des tabulations sans modifier la source.
Et rien n'empêche de mettre une extension CSV au nom de fichier, même si ce n'est pas vraiment un CSV.

la V2

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
Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}" 
Sub test()
Dim txt As String, Fichier As String
Fichier = Split(ThisWorkbook.FullName, ".xls")(0) & ".CSV"
ActiveSheet.UsedRange.Copy
txt = PressePapier
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(Fichier) = True Then fso.DeleteFile Fichier, True
Set NewFichier = fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
 
End Sub
Public Property Let PressePapier(Value)
    With CreateObject(DATAOBJECT_BINDING)
        .SetText Value
        .PutInClipboard
    End With
End Property
 
Public Property Get PressePapier()
    With CreateObject(DATAOBJECT_BINDING)
        .GetFromClipboard
        PressePapier = .GetText
    End With
End Property

30/08/2017, 14h25
patricktoulon

re

re
Allons robert!!! FSO!!!!

je ne retrouvais plus justement cet exemplaire avec les api que tu avais proposé dans le passé

après entre nous je fait la même chose sans apis et sans FSO

j'utilise l'object htmlfile mais je pourrais aussi utilise le form.dataobject c'est pareil

bref il le choix, la solution proposé avec saveas reste la plus simplepour sauver la page entiere et pour un novice

maintenant si il veux seulement sauver une partie du sheets quel quelle soit il devra utiliser une de nos astuce parmi tant d'autres encore
30/08/2017, 14h32
Invité

je n'utilise en générale que fso! ça ne me complique pas quand je change de langage de programmation.

problème de formalisme entre les méthodes de langage et dans ce cas de figure c'est rapide!
30/08/2017, 14h38
felix-o

En effet je réagis aux précédents messages et je crois que je me suis mal exprimé!!!
Toutes mes excuses, c'e sont bien des fichier txt que je souhaite obtenir à partir de chaque onglet....
Merci pour votre aide
30/08/2017, 17h23
Menhir

Citation:

Envoyé par patricktoulon

maintenant si il veux seulement sauver une partie du sheets quel quelle soit il devra utiliser une de nos astuce parmi tant d'autres encore

Perso, je copierais la partie souhaitée dans un onglet vide et je ferais un SaveAs.

Mais c'est une question de goût et d'habitude.
Comme le disait dysorthographie, chacun peut avoir des raisons différentes d'utiliser différentes méthodes.
30/08/2017, 19h39
patricktoulon

re

salut menhir

perso l'ajout de sheets temp ,je l'utilise qu'en cas d'absolue nécessité au cas ou j'aurais par exemple une sélection non contigüe a mettre dans une variable tableau ou un traitement spécial sur les valeurs
30/08/2017, 21h08
felix-o

Merci à tous pour votre aide!
Bonne continuation...