Problème de code WritetoCSV

Version imprimable

Bonjour à tous,

Je vous expose mon petit problème :

J'utilise une macro ci-dessous qui m'enregistre un tableau Excel en un fichier CSV (utf8).
La macro n'est pas de moi et j'ignore son origine. Je m'en excuse d'avance auprès de son créateur.
Je ne l'ai que très légèrement modifiée et la macro fonctionne. Elle est globalement ce que je recherche.

Toutefois la macro n'exporte pas toutes mes valeurs. Par exemple quand ma plage de valeurs contient une colonne vide elle s'arrête à la colonne vide et ne traite pas le reste situé sur les colonnes suivantes.
Ma question est : savez-vous comment modifier la macro afin qu'elle enregistre tout, colonnes vides incluses ?

Merci d'avance pour l'aide que je peux obtenir.
Crdt,
G
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 Public Sub WriteCSV() Set wkb = ActiveSheet Dim fileName As String Dim MyPath As String Dim MaxCols As Integer MyPath = "H:\" fileName = "18068-02_" & Format(Date, "yyyymmdd") & Format(Time, "hhmm") & ".csv" 'Makes sure the path name ends with "\": If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\" 'Makes sure the filename ends with ".csv" If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv" 'Copies the sheet to a new workbook: Sheets("test").Copy If fileName = "False" Then End End If On Error GoTo eh Const adTypeText = 2 Const adSaveCreateOverWrite = 2 Dim BinaryStream Set BinaryStream = CreateObject("ADODB.Stream") BinaryStream.Charset = "UTF-8" BinaryStream.Type = adTypeText BinaryStream.Open For r = 1 To 20 s = "" c = 1 While Not IsEmpty(wkb.Cells(r, c).Value) s = s & wkb.Cells(r, c).Value & "," c = c + 1 Wend BinaryStream.WriteText s, 1 Next r BinaryStream.SaveToFile MyPath & fileName, adSaveCreateOverWrite BinaryStream.Close ActiveWorkbook.Close Savechanges:=False MsgBox "CSV généré sous H:\" eh: End Sub

Bonjour,

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
Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}" 
Public Sub WriteCSV()
Set wkb = ActiveSheet
Dim fileName As String
Dim MyPath As String
Dim MaxCols As Integer
MyPath = "H:\"
 
fileName = "18068-02_" & Format(Date, "yyyymmdd") & Format(Time, "hhmm") & ".csv"
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("test").UsedRange.Copy
 
If fileName = "False" Then
End
End If
 
'On Error GoTo eh
Const adTypeText = 2
Const adSaveCreateOverWrite = 2
 
With CreateObject("ADODB.Stream")
    .Charset = "UTF-8"
    .Type = adTypeText
    .Open
    .WriteText Replace(PressePapier, vbTab, ",")
    .SaveToFile MyPath & fileName, adSaveCreateOverWrite
    .Close
 
ActiveWorkbook.Close Savechanges:=False
 End With
MsgBox "CSV généré sous H:\"
 
eh:
 
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

19/12/2017, 16h46
Gabriel_

Merci pour le code mais il m'indique une erreur à la ligne
"With CreateObject(DATAOBJECT_BINDING)"

et il dit :
Un composant activex ne peut pas créer d'objet...
Une histoire de références VBA !?
19/12/2017, 18h57
Invité

Tu as créé la.constate

Code:

Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
19/12/2017, 20h20
Gabriel_

En effet je l'ai oublié dans la copie. Pfff.
A présent ça fonctionne en effet exactement comme souhaité.
Merci beaucoup encore.