Macro save Excel en CSV

**khech** · 01/07/2015, 01h15

Bonjour,
j'ai mon macro qui sauvegarde une de mes feuille excel en csv. Il marche bien mais dès que je fais mon sauvegarde, je perds mes derniers modification sur mon fichier excel.
J'aimerai faire de sorte que le csv soit sauvegardé et que le fichier excel reste intacte et ne ferme pas.

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
 
Sub SaveCSV()
    Dim rep As String
    Dim Chemin As String, Fichier1 As String
    Chemin = dossier_cible & "\"
    Fichier1 = Range("A5").Value & "_" & Range("J1").Value & " " & Format(Date, "yyyy")
 
    Application.DisplayAlerts = False
    With ActiveWorkbook
    With ActiveSheet
      .Rows("1:3").Delete
     .SaveAs Filename:=Chemin & Fichier1 & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    End With
    MsgBox "Fichier sortie enregistré sous : " & dossier_cible & "\" & Fichier1
    End With
     Application.DisplayAlerts = True
End Sub

Merci d'avance.

Invité · 01/07/2015, 10h03

Bonjour,
test ça

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
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
#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
ActiveSheet.UsedRange.Copy
txt = ClipBoard_GetData
txt = Replace(txt, vbTab, ";")
 Chemin = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".csv"
    Set fso = CreateObject("Scripting.FileSystemObject")
        Set NewFichier = fso.OpenTextFile(Chemin, 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

**PMO2017** · 01/07/2015, 12h03

Bonjour,

Peut être comme cela

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
29
30
31
32
 
Sub SaveCSV()
    Dim rep As String
    Dim Chemin As String, Fichier1 As String
    Chemin = dossier_cible & "\"
    Fichier1 = Range("A5").Value & "_" & Range("J1").Value & " " & Format(Date, "yyyy")
 
'--- Fait une copie temporaire du classeur d'origine ---
Dim WB As Workbook
ActiveWorkbook.SaveCopyAs Chemin & Fichier1 & ".xlsm"
Set WB = Workbooks.Open(Chemin & Fichier1 & ".xlsm")
'--------------------------------------------------------
 
    '--- Le traitement s'applique sur la copie temporaire du classeur d'origine ---
    Application.DisplayAlerts = False
    With WB
    With WB.ActiveSheet
      .Rows("1:3").Delete
     .SaveAs Filename:=Chemin & Fichier1 & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    End With
    MsgBox "Fichier sortie enregistré sous : " & dossier_cible & "\" & Fichier1
    End With
     Application.DisplayAlerts = True
    '-------------------------------------------------------------------------------
 
'--- Détruit la copie temporaire du classeur d'origine ---
WB.Close savechanges:=False
Set WB = Nothing
Kill Chemin & Fichier1 & ".xlsm"
'---------------------------------------------------------
 
End Sub

**khech** · 01/07/2015, 14h33

Bonjour

PMO2017
Bonjour,
Peut être comme cela

,
ta solution semble marcher.
Merci bien

.

**khech** · 02/07/2015, 09h29

Bonjour,
il se trouve que mon application a une page d'accueil et dès que je lance le macro SaveCSV il fait le travail nikel mais par contre au lieu sur la feuille d'origine, il affiche la page d'accueil.
Existe il une solution pour résoudre ce problème ? j'ai essayé de bidouiller mais rien.
Merci par avance.

**PMO2017** · 02/07/2015, 10h04

Bonjour,

Alors peut être comme cela (voir les ###)

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
29
30
31
32
33
34
35
36
37
38
Sub SaveCSV()
    Dim rep As String
    Dim Chemin As String, Fichier1 As String
    Chemin = dossier_cible & "\"
    Fichier1 = Range("A5").Value & "_" & Range("J1").Value & " " & Format(Date, "yyyy")
 
'--- Fait une copie temporaire du classeur d'origine ---
Dim WB As Workbook
ActiveWorkbook.SaveCopyAs Chemin & Fichier1 & ".xlsm"
Set WB = Workbooks.Open(Chemin & Fichier1 & ".xlsm")
'--------------------------------------------------------
 
 
'#### On séléctionne la bonne feuille qui devient active (ActiveSheet)
WB.Sheets("Nom de la bonne feuille").Select 'adapter du nom de la bonne feuille
'####
 
    '--- Le traitement s'applique sur la copie temporaire du classeur d'origine ---
    Application.DisplayAlerts = False
    With WB
 
    With WB.ActiveSheet   '###
 
      .Rows("1:3").Delete
     .SaveAs Filename:=Chemin & Fichier1 & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    End With
    MsgBox "Fichier sortie enregistré sous : " & dossier_cible & "\" & Fichier1
    End With
     Application.DisplayAlerts = True
    '-------------------------------------------------------------------------------
 
'--- Détruit la copie temporaire du classeur d'origine ---
WB.Close savechanges:=False
Set WB = Nothing
Kill Chemin & Fichier1 & ".xlsm"
'---------------------------------------------------------
 
End Sub

Macro save Excel en CSV

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager