Macro VBA assistance pour finalisation

Version imprimable

Bonjour aux forumeurs,

Avec le concours de plusieurs post, après plusieurs tentatives vaines je n'arrive pas a finaliser correctement ma macro.
Mon souhait serait qu'a l’exécution de celle ci je puisse avoir la fenêtre de dialogue (Enregistrer sous) qui apparaisse avec mon chemin de destination. mais que soit valide et apparaisse le nom de mon fichier contenu dans ma cellule B10.
Jusque la cela semble simple mais je n'y arrive pas.
Dans la macro ci dessous l'enregistrement ce fait bien mais pas en validant avec le nom, simplement en cliquant sur la croix....!!

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
Sub Sauve()
'
' Sauve Macro
 
   Range("B9").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A17").Select
    ActiveWindow.SmallScroll Down:=18
    Range("A17:E156").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets(Array("Provision", "Taux", "Stock-Chine", "GPL-HP", "glemea-1")).Select
    Sheets("GPL-HP").Activate
    ActiveWindow.SelectedSheets.Delete
    Columns("C:H").Select
    Selection.EntireColumn.Hidden = True
    Columns("J:K").Select
    Selection.EntireColumn.Hidden = True
    Columns("P:P").Select
    Selection.EntireColumn.Hidden = True
    Columns("S:S").Select
    Selection.EntireColumn.Hidden = True
    With Application.FileDialog(2)
  Range("B10").Select
    ActiveWorkbook.saveas Filename:=[B10].Value & ".xlsm"
        .InitialFileName = Nom
        .Show
         On Error Resume Next 'si annulé
        Chemin = .SelectedItems(1)
     End With
     If Err.Number = 0 Then
       ActiveWorkbook.saveas Filename:=Destination & [B10].Value & ".xlsm"
     End If
    ActiveSheet.Shapes.Range(Array("Button 4")).Select
    Selection.Delete
    ActiveSheet.Shapes.Range(Array("Button 5")).Select
    Selection.Delete
End Sub

Si quelqu'un pouvait m'accompagner et m'expliquer ce serait sympa
Merci a vous

Bonjour,

Teste pour voir si ça convient :

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
 
Sub Sauve()
 
    Dim Nom As String
    Dim Chemin As String
 
    'ne garde que le résultat de la fonction
    Range("B9").Value = Range("B9").Value
 
    Range("A17:E156").Value = Range("A17:E156").Value
 
    Sheets(Array("Provision", "Taux", "Stock-Chine", "GPL-HP", "glemea-1")).Delete
 
    Range("C:H,J:K,P:P,S:S").EntireColumn.Hidden = True
 
    Nom = Range("B10").Value & ".xlsm"
 
    With Application.FileDialog(2)
 
        .InitialFileName = Nom
        .Show
 
        On Error Resume Next 'si annulé
        Chemin = .SelectedItems(1)
 
    End With
 
    If Err.Number = 0 Then ActiveWorkbook.SaveAs Chemin & Nom Else Exit Sub
 
    ActiveSheet.Shapes.Range("Button 4").Delete
    ActiveSheet.Shapes.Range("Button 5").Delete
 
End Sub

10/09/2015, 10h58
Muzzik

Cela fonctionne mais....

Bonjour Theze,

Merci d'avoir pris le temps de regarder mon problème et d'y avoir apporté des corrections.
Cela fonctionne bien comme je le désire sauf que lors de l'enregistrement il me nomme mon fichier 2 fois comme ceci "CLS-CFA_20150909-Test-XX0001.xlsxCLS-CFA_20150909-Test-XX0001"
Je ne suis pas suffisamment caler pour modifier ton code....

Sinon pour le reste c'est génial,

Merci de ton retour

Oups,

Mais oui, j'ai concaténé le nom du fichier au moment de l'enregistrement, voici le code rectifié :

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
 
Sub Sauve()
 
    Dim Nom As String
    Dim Chemin As String
 
    'ne garde que le résultat de la fonction
    Range("B9").Value = Range("B9").Value
 
    Range("A17:E156").Value = Range("A17:E156").Value
 
    Sheets(Array("Provision", "Taux", "Stock-Chine", "GPL-HP", "glemea-1")).Delete
 
    Range("C:H,J:K,P:P,S:S").EntireColumn.Hidden = True
 
    Nom = Range("B10").Value & ".xlsm"
 
    With Application.FileDialog(2)
 
        .InitialFileName = Nom
        .Show
 
        On Error Resume Next 'si annulé
        Chemin = .SelectedItems(1)
 
    End With
 
    If Err.Number = 0 Then ActiveWorkbook.SaveAs Chemin Else Exit Sub
 
    ActiveSheet.Shapes.Range("Button 4").Delete
    ActiveSheet.Shapes.Range("Button 5").Delete
 
End Sub

10/09/2015, 16h59
Muzzik

!!!

Merci theze, mais il me semble que tu me renvois le même code
10/09/2015, 17h08
aziz1015

Bonjour,

Theze avait fait l'erreur à la ligne 28 qu'il a changé dans le second code, la ligne 28 du premier code :

Code:

If Err.Number = 0 Then ActiveWorkbook.SaveAs Chemin & Nom Else Exit Sub

a été changé comme cela dans le deuxième code :

Code:

If Err.Number = 0 Then ActiveWorkbook.SaveAs Chemin Else Exit Sub

As tu au moins essayé de compiler ?

Cordialement
10/09/2015, 17h42
Muzzik

Bonjour,

J'ai testé le code et cela ne fonctionne pas correctement,

alors maintenant je n'ai plus de doublons de nom à l'enregistrement, mais désormais la macro s’exécute correctement, ma fenêtre de dialogue enregistrer sous apparaît avec le nom de mon fichier (récupéré en B10) mais lors de la validation de mon enregistrement le fichier se nomme de sa forme initiale...!!

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
Sub Sauve()
 
    Dim Nom As String
    Dim Chemin As String
 
    'ne garde que le résultat de la fonction
    Range("B9").Value = Range("B9").Value
 
    Range("A17:E156").Value = Range("A17:E156").Value
 
    Sheets(Array("Provision", "Taux", "Stock-Chine", "GPL-HP", "glemea-1")).Delete
 
    Range("C:H,J:K,P:P,S:S").EntireColumn.Hidden = True
 
    Nom = Range("B10").Value & ".xlsm"
 
    With Application.FileDialog(2)
 
        .InitialFileName = Nom
        .Show
 
        On Error Resume Next 'si annulé
        Chemin = .SelectedItems(1)
 
    End With
 
    If Err.Number = 0 Then ActiveWorkbook.SaveAs Nom Else Exit Sub
 
    ActiveSheet.Shapes.Range("Button 4").Delete
    ActiveSheet.Shapes.Range("Button 5").Delete
 
End Sub

10/09/2015, 17h59
Muzzik

Yes un grand merci

Super AZIZ

un simple & et tout fout le camp....

Un grand merci a toi et Thèze,