Export onglets en csv avec tabulation

**felix-o** · 30/08/2017, 12h06

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**unparia** · 30/08/2017, 12h37

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 .

**patricktoulon** · 30/08/2017, 12h49

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

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
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

Invité · 30/08/2017, 12h59

Bonjour Patrick, unparia et felix-o,

Code Sub test seule important! :

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
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

**felix-o** · 30/08/2017, 13h33

Bonjour à tous et merci!
Patrick, si j'ai bien compris, j'ai deux macro à lancer?

**Menhir** · 30/08/2017, 13h57

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

Invité · 30/08/2017, 14h12

la V2

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
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

**patricktoulon** · 30/08/2017, 14h25

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

Invité · 30/08/2017, 14h32

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!

**felix-o** · 30/08/2017, 14h38

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

**Menhir** · 30/08/2017, 17h23

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.

**patricktoulon** · 30/08/2017, 19h39

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

**felix-o** · 30/08/2017, 21h08

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

Export onglets en csv avec tabulation [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager