Sauvegarde non effectuée

Version imprimable

Voir 40 message(s) de cette discussion en une page

18/08/2012, 18h14
grisan29

bonjour Mercatog

je te joints le fichier que je viens d'épurer

Pascal

J'ai testé le code suivant avec succès

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
Private Sub NouvelleFeuille_Click()
Dim Nom As String, Chemin As String
Dim shNew As Worksheet
 
Application.ScreenUpdating = False
Chemin = "C:\Save_Devis_ExcelGStock\Devis"
 
If Dir(Chemin, vbDirectory) <> "" Then
    With ThisWorkbook.Worksheets("Facturation")
        Set shNew = Sheets.Add
        .UsedRange.Copy
        With shNew.Range("A1")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
 
        shNew.Move
        Set shNew = Nothing
        Nom = .Range("D17").Value & "-" & .Range("J5").Value & ".xls"
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=Chemin & "\" & Nom, FileFormat:=xlExcel8
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
 
        .Range("J5:J8", "C16").ClearContents
        If .[MTTC].Row - 9 > 19 Then
            .Range("C19:C" & .[MTTC].Row - 9).EntireRow.Delete
        ElseIf .[MTTC].Row - 9 = 19 Then
            .Rows(19).Clear
        End If
 
        Select Case UCase(.Range("D1"))
            Case Is = "FACTURE"
                .Range("S7") = .Range("S7") + 1
            Case Is = "DEVIS"
                .Range("S8") = .Range("S8") + 1
        End Select
    End With
    MsgBox "Archivage terminé avec succès de " & Nom
Else
    MsgBox "Chemin " & Chemin & " inéxistant"
End If
End Sub

20/08/2012, 13h03
grisan29

bonjour Mercatog

aujourdhui j'ai apportet mon portable pour essyer car celui ci a de retour son problème d'automation
donc ca bug a

Code:

ActiveWorkbook.SaveAs Filename:=Chemin & "\" & Nom, FileFormat:=xlExcel8

toujours pour les meme raisons et je n'ai absolument rien changé a ton code
nouveau message avant celui d'erreur automation

Citation:

erreur système & H80004005 (-2147467259)

Pascal

bonjour Mercatog
voic le code qui fonctionne mais m'efface 3 lignes de trop dans le bas de feuilles entre les données et le bas de page

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
Private Sub NouvelleFeuille_Click()
Dim Nom As String, Chemin As String
Dim shNew As Worksheet
 
Application.ScreenUpdating = False
Chemin = "C:\Save_Devis_ExcelGStock\Devis"
 
If Dir(Chemin, vbDirectory) <> "" Then
    With ThisWorkbook.Worksheets("Facturation")
        Set shNew = Sheets.Add
        .UsedRange.Copy
        With shNew.Range("A1")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
 
        shNew.Move
        Set shNew = Nothing
        Nom = .Range("D17").Value & "-" & .Range("J5").Value & ".xls"
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=Chemin & "\" & Nom, FileFormat:=xlExcel8
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
 
        .Range("J5:J8", "C16").ClearContents
        If .[MTTC].Row - 9 > 19 Then
            .Range("C19:C" & .[MTTC].Row - 9).EntireRow.Delete
        ElseIf .[MTTC].Row - 9 = 19 Then
            .Rows(19).Clear
        End If
 
        Select Case UCase(.Range("D1"))
            Case Is = "FACTURE"
                .Range("S7") = .Range("S7") + 1
            Case Is = "DEVIS"
                .Range("S8") = .Range("S8") + 1
        End Select
    End With
    MsgBox "Archivage terminé avec succès de " & Nom
Else
    MsgBox "Chemin " & Chemin & " inéxistant"
End If
End Sub

Voir 40 message(s) de cette discussion en une page