Nommer excel+PDF depuis source CONCATENER

Version imprimable

1 pièce(s) jointe(s)

Bonjour

Voila je voudrais de l'aide pour mon fichier en piece jointe.

j'aimerais pouvoir enregistré mon fichier depuis le bouton contrôle avec comme nom qui se trouve dans le cellule "source" en page titi;F3 .

J'ai mon bouton contrôle fonctionnel mais la je coince.

Merci d'avance pour votre aide
je suis toujours novice ...:lol:

Voici le code qui enregistre puis le sauvegarde en PDF a la source.

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub Fermer_Classeur_avec_PDF()
 
Dim Feuille As Worksheet
              For Each Feuille In ThisWorkbook.Worksheets
              If Feuille.Name <> "" Then Feuille.Protect "TOTO", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowSorting:=True
              Next
 
 
Dim Rep As Long, sFichier As String
Dim FSO As Object
 
    Rep = MsgBox("Voulez-vous sauvegarder avec les onglets en pdf ?", vbYesNo)
        If Rep = vbYes Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        sFichier = ThisWorkbook.Path & "\" & FSO.GetBaseName(ThisWorkbook.Name) & ".pdf"
 
        If FSO.FileExists(sFichier) Then
            Rep = MsgBox("Le fichier PDF existe déjà, confirmer son écrasement ?", vbYesNo)
            If Rep = vbYes Then SavePDF sFichier
        Else
            SavePDF sFichier
        End If
        Set FSO = Nothing
 
     End If
End Sub
 
Private Sub SavePDF(sNomFichier As String)
 
' Pour choisir les onglet en PDF
 
Dim Ar(1) As String
 
    Ar(0) = "titi"
    Ar(1) = "tata"
 
    Application.ScreenUpdating = False
 
    Sheets(Ar).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=sNomFichier, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=True
 
    Application.ScreenUpdating = True
 
   'Permer de ranger les cellule par defaut sur chaque onglet
 
    Sheets("tata").Select
    Range("B1").Select
    Sheets("titi").Select
    Range("C1").Select
 
 
    Sheets("titi").Visible = True
    Sheets("tata").Visible = True
    Sheets("toto").Visible = False
 
 
    ActiveWorkbook.Save 'Fermeture Avec sauvegarde
    CancelSortie = False 'reactive la croix de fermeture
    ActiveWorkbook.Close
 
End Sub

1 pièce(s) jointe(s)

Salut, Affecter un bouton à la procédure Enregistrer.

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
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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Sub Enregistrer()
Dim Rep As Long, sFichier As String
Dim FSO As Object, sDossierSauvegarde As String
 
    sDossierSauvegarde = ThisWorkbook.Path & "\" & "Sauvegarde"
    CreationDossier sDossierSauvegarde
 
    sFichier = Feuil1.Range("F3")
    If NomFichierValide(sFichier) Then
        Rep = MsgBox("Voulez-vous sauvegarder en pdf ?", vbYesNo)
        If Rep = vbYes Then
            Set FSO = CreateObject("Scripting.FileSystemObject")
            sFichier = sDossierSauvegarde & "\" & sFichier
            If FSO.FileExists(sFichier & ".pdf") Then
                Rep = MsgBox("Le fichier pdf existe déjà, confirmer son écrasement ?", vbYesNo)
                If Rep = vbYes Then SavePDF_XLS sFichier
            Else
                SavePDF_XLS sFichier
            End If
            Set FSO = Nothing
        End If
    Else
        Feuil1.Range("F3").Select
        MsgBox "Nom de fichier invalide", vbCritical + vbOKOnly
    End If
End Sub
 
Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function
 
Private Sub SavePDF_XLS(sNomFichier As String)
Dim Ar(1) As String
 
    Ar(0) = Feuil1.Name
    Ar(1) = Feuil2.Name
 
    Application.ScreenUpdating = False
    Sheets(Ar).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=sNomFichier & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    Sheets(Feuil1.Name).Select
 
    Application.DisplayAlerts = False
    ThisWorkbook.SaveCopyAs sNomFichier & ".xlsb"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

01/05/2017, 19h21
stef3700

1 pièce(s) jointe(s)

Merci j’ai essayer il y a une erreur de compilation

de l'aide Svp
Pièce jointe 270221

Merci
01/05/2017, 21h13
kiki29

Salut, à toi de voir et appliquer : Développer avec Office 64 bits

Même si Microsoft déconseille l'installation d'une version 64 bits d'Office.

Citation:

Office 32 bits est recommandé pour la plupart des utilisateurs
Nous recommandons la version 32 bits d’Office pour la plupart des utilisateurs, car elle offre une plus grande compatibilité avec la plupart des autres applications, en particulier les compléments tiers. C’est la raison pour laquelle la version 32 bits d’Office est installée par défaut, même sur les systèmes d’exploitation Windows 64 bits. Sur ces systèmes, le client Office 32 bits est pris en charge en tant qu’installation Windows-32-on-Windows-64 (WOW64). WOW64 est l’émulateur x86 qui permet l’exécution de façon transparente des applications Windows 32 bits sur les systèmes Windows 64 bits. Cela permet aux utilisateurs de continuer à utiliser les contrôles ActiveX et les compléments COM Microsoft avec la version 32 bits d’Office.

Merci oui effectivement mais l’ensemble des postes que se servirons du fichier serons en 64Bits
J ai trouver puis testé avec PtrSafe fonctionne.*

Par contre le fait d'ajouté un dossier Sauvegarde pas mal mais je souhaiterai qu il enregistre directement ou y il a la source du fichier ouvert .
après mais recherches je coince ..

Merci d'avance
Stef
;)
Code:

1 2 3 4 5 6 Option Explicit Private Declare PtrSafe Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _ (ByVal hwnd As Long, _ ByVal pszPath As String, _ ByVal lngsec As Long) As Long

02/05/2017, 00h12
stef3700

Bonsoir Merci a KIKI29
j'ai rectifier le code
Sur le format de la date effectivement le "/" pas correcte dans le windows ,
Puis en ligne 74

Code:

ThisWorkbook.SaveCopyAs sNomFichier & ".xlsb"

changer en xlsm

Il me reste plus qu'il enregistre dans le dossier source si possible...:)

Merci d’avance
A plus

Salut, d'urgence Antidote car c'est vraiment catastrophique.

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
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
Sub Enregistrer()
Dim Rep As Long, sFichier As String
Dim FSO As Object
 
    sFichier = Feuil1.Range("F3")
    If NomFichierValide(sFichier) Then
        Rep = MsgBox("Voulez-vous sauvegarder en pdf ?", vbYesNo)
        If Rep = vbYes Then
            Set FSO = CreateObject("Scripting.FileSystemObject")
            If FSO.FileExists(ThisWorkbook.Path & "\" & sFichier & ".pdf") Then
                Rep = MsgBox("Le fichier pdf existe déjà, confirmer son écrasement ?", vbYesNo)
                If Rep = vbYes Then SavePDF_XLS ThisWorkbook.Path & "\" & sFichier
            Else
                SavePDF_XLS ThisWorkbook.Path & "\" & sFichier
            End If
            Set FSO = Nothing
        End If
    Else
        Feuil1.Range("F3").Select
        MsgBox "Nom de fichier invalide", vbCritical + vbOKOnly
    End If
End Sub
 
Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const CaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(CaracInterdits)
        If InStr(sChaine, Mid$(CaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function
 
Private Sub SavePDF_XLS(sNomFichier As String)
Dim Ar(1) As String
 
    Ar(0) = Feuil1.Name
    Ar(1) = Feuil2.Name
 
    Application.ScreenUpdating = False
    Sheets(Ar).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=sNomFichier & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    Sheets(Feuil1.Name).Select
 
    On Error Resume Next
    ThisWorkbook.SaveCopyAs sNomFichier & ".xlsb"
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

02/05/2017, 18h16
stef3700

Merci KIKI29
Fonctionne parfaitement

Stef