Code a modifier pour séparer chemin devis et facture
bonjour a vous tous
j'ai le code issu de l'enregistreur,ci-dessous qui me permets de sauvegarder mes devis, facture, facture d'acompte facture acquittée, débarrassé des codes et boutons dans le même dossier mais je voudrais pouvoir les séparées pour les mettre chacun dans leurs dossiers respectif en fonction de l'affichage dans "D1"où "DOC_TITRE"
Sub envoifacnu()
Dim F As Worksheet
Dim Chemin As String
Dim Client As String
Dim Sh As Shape
Application.ScreenUpdating = False
Set F = ThisWorkbook.Sheets(WS_FACTURE)
Chemin = "D:\Facturation-v1s"
Client = F.Range("DOC_TITRE").Value & " - " & F.Range("DOC_CLIENT").Value
Sheets(WS_FACTURE).Copy
For Each Sh In ActiveSheet.Shapes
If Sh.Type <> msoPicture Then
Sh.Delete
End If
Next Sh
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues
Range("A1").Select
Application.DisplayAlerts = False ' Si fichier identique présent : l'écrase sans alerte
ActiveWorkbook.SaveAs Filename:=Chemin & "\Factureseule\" & Client & ".xlsx"
ActiveWorkbook.Close
Sheets(WS_FACTURE).Activate
End SubPascal
Bonsoir
Pour déterminer le bon chemin
Select Case Range("D1")
Case "Facture"
Chemin = "D:\Facturation-v1s\Factureseule\Factures\"
Case "Devis"
Chemin = "D:\Facturation-v1s\Factureseule\Devis\"
Case "Facture acompte"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acompte\"
Case "Facture acquitée"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acquitée\"
End Select
'
'
'
ActiveWorkbook.SaveAs Filename:=Chemin & Client & ".xlsx"
'
'
'bonsoir banzai64
merci de ta réponse mais après essai je ne sais pas où est parti le document, mais peut etre ai je mal intégré ta solution
Sub envoifacnu()
Dim F As Worksheet
Dim Chemin As String
Dim Client As String
Dim Sh As Shape
Application.ScreenUpdating = False
Set F = ThisWorkbook.Sheets(WS_FACTURE)
Chemin = "D:\Facturation-v1s"
Client = F.Range("DOC_TITRE").Value & " - " & F.Range("DOC_CLIENT").Value
Sheets(WS_FACTURE).Copy
For Each Sh In ActiveSheet.Shapes
If Sh.Type <> msoPicture Then
Sh.Delete
End If
Next Sh
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues
Range("A1").Select
Application.DisplayAlerts = False ' Si fichier identique présent : l'écrase sans alerte
Select Case Range("DOC_TITRE")
Case "Facture"
Chemin = "D:\Facturation-v1s\Factureseule\Factures\"
Case "Devis"
Chemin = "D:\Facturation-v1s\Factureseule\Devis\"
Case "Facture acompte"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acompte\"
Case "Facture acquitée"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acquitée\"
End Select
ActiveWorkbook.SaveAs Filename:=Chemin & Client & ".xlsx"
'ActiveWorkbook.SaveAs Filename:=Chemin & "\Factureseule\" & Client & ".xlsx"
ActiveWorkbook.Close
Sheets(WS_FACTURE).Activate
End SubPascal
Bonsoir,
Peut-être en rajoutant F. devant le dernier Range("DOC_TITRE")...
Peut-être....
Bonsoir cousinhub
comme tu l'a dit peut etre eh ben c'est averé ce n'est pas mieux je ne sais où est parti le documentet pourtant le bouton reste enfoncé peu de temps pour monter qu'il a fait quelquechose
Pascal
Re-,
En mode pas-à-pas, et que tu passes ton curseur sur "Chemin", qu'est-ce que ça indique?
re cousinhub
j'ai suivi ce que tu m'as dit et découvert que le bug vient de plus haut hors quand ca enregistrait dans le même dossiers pas de soucis
Pascal
Re-,
A ce moment du déroulement, c'est normal que F te renvoie "Nothing"..
Il faut dérouler en appuyant sur F8, jusqu'à la ligne qui détermine "Chemin", dans tes Select Case...
Bonjour
Tu n'es pas nouveau et tu sais que fournir un fichier est un bonus pour l'obtention d'une réponse
Amicalement
bonsoir banzai64
bien sur que je sais qu'il faut fournir un fichier exemple mais pour ce soir je ne sais si j'aurais le temps
ce fichier représente en faux la réalité
cousinhub
pour le pas a pas il fige excel a partir de la ligne
Sheets(WS_FACTURE).Copyen créant un autre classeur figé lui aussi
il faut passer le gestionnaire de taches pour fermer excel
Pascal
Bonjour,
Comme ce n'est pas un onglet original, il n'est pas possible de répondre à coup sûr...
Dans la cellule D17, tu n'as aucun cas évoqué dans le Select Case (Facture acquittée suivie d'un numéro....)
Tu n'as aucune formule dans cet onglet (ou alors, je ne comprends pas du tout pourquoi tu veux faire un Cells.Copy, suivi d'un Paste Spécial (valeurs))
Bref, travailler sur ce fichier (j'ai uniquement téléchargé le fichier le plus en bas de ton post), n'est pas possible, car il ne semble pas représentatif de ton fichier réel...
Bon courage
bonsoir cousinhub
je pensais que le fichier que j'ai mis hier soir (voir ce matin) serai représentatif pour ce que j'attendais, concernant mon fichier réel il est ici https://www.excel-pratique.com/fr/telechargements/gestion-commerciale/classeur-devis-et-facturation-no119.phpmais je le fait évoluer pour avoir des factures où devis sans leurs codes et boutons mais en gardant le logo
donc le code que j'ai mis est dans le module Mgestion de mon fichier actuel mais pas dans celui du lien et j'ai rajouter un bouton pour que cela fonctionne,mais je préfèrerais que cela se fasse au moment d'enregistrer la facture en cliquant sur le bouton "Créé documents dans la Base" sur l'usf liste_boutons
j'ai également créer un dossier "factureseule" avec des sous dossiers que l'on voit dans mon premier post
j'ai également remplacer le fichier client par un autre mais je n'arrive pas le faire chercher les clients dans le classeur sous c:
de toute il faut que je commence essayer de comprendre les modules de classe car pour ce fichier je pense qu'il y a un mixage a faire
voila ce que je peux dire de plus ce soir
Pascal
Bonjour
Supprimes la macro placée dans le Module1 (risque de confusion)
Remplaces la macro actuelle qui est dans le module de la feuille par celle-ci
Private Sub envoifacnu_Click()
Dim F As Worksheet
Dim Chemin As String
Dim Client As String
Dim Sh As Shape
Set F = ThisWorkbook.Sheets(WS_FACTURE)
Select Case F.Range("D1")
Case "DEVIS"
Chemin = "D:\Facturation-v1s\Factureseule\Devis\"
Case "FACTURE ACOMPTE"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acompte\"
Case "FACTURE ACQUITTEE"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acquitée\"
Case "FACTURE"
Chemin = "D:\Facturation-v1s\Factureseule\Factures\"
Case Else
MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
End
End Select
Client = F.Range("D1") & " - " & F.Range("J5")
Application.ScreenUpdating = False
F.Copy
With ActiveWorkbook
With .Sheets(1)
For Each Sh In .Shapes
If Sh.Type <> msoPicture Then
Sh.Delete
End If
Next Sh
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Range("A1").Select
End With
Application.DisplayAlerts = False ' Si fichier identique présent : l'écrase sans alerte
.SaveAs Filename:=Chemin & Client & ".xlsx"
.Close
End With
End Subbonjour BrunoM45
merci pour ta réponse que je n'ai pas encore essayer,le module1 n'existe plus dans le fichier que j'utilise
tu dit
Remplaces la macro actuelle qui est dans le module de la feuille par celle-ci
mais j'ai déjà le code du sous total dedans
bon je vais télécharger le classeur et essayer dessus
je pense qu'il y a une ligne de code a mettre derrière le bouton "enregistrer dans la base"pour le faire en même temps
Pascal
Bonjour
Hummm je dois sentir le gaz
J'ai pris comme base de travail le 4ème fichier que tu as posté le 05 Juil 2015, 23:22
Dans ce fichier tu as une macro dans un module et une macro dans le module de la feuille
bonjour Banzai
tu tout a fais raison la base de travail demandé était celle du 5 a 23h22 mais cousinhub que je salut, m'a dit
je lui ai donné dans le post de 06 Juil 2015, 18:33 le lien vers le bon fichier qui est en téléchargement dans la gestion commercialeComme ce n'est pas un onglet original, il n'est pas possible de répondre à coup sûr...
voila le fichier réel que j’essaie de modifier pour avoir des devis et factures débarrasser des codes et boutons
Pascal
Bonjour
Sur la base d'un fichier que TU as fourni, je te trouve une solution, il y a juste à dire c'est bon, c'est pas bon
C'est tout ce que je demande
Je dormirai quand même
bonsoir banzai64
merci pour le code que tu as donné et que j'ai essayer sur le fichier que j'ai mis le 5 a 23h22
et cela fonctionne très bien, il n'a que "facture acquiittée qui cause un bug a la dernière ligne
.SaveAs Filename:=Chemin & Client & ".xlsx"avec l'erreur d'exécution 1004
sur le fichier réel je suis obliger de mettre le code en public où le mettre dans la même page de code que l'appel
Pascal
Bonsoir
grisan29 a écrit :et cela fonctionne très bien, il n'a que "facture acquiittée qui cause un bug a la dernière ligne
Dans le code pour le chemin il faut rajouter un t à acquittée
Case "FACTURE ACQUITTEE"
Chemin = "D:\Facturation-v1s\Factureseule\Facture acquittée\" ' Il faut rajouter un t
Case "FACTURE"
Chemin = "D:\Facturation-v1s\Factureseule\Factures\"grisan29 a écrit :sur le fichier réel je suis obliger de mettre le code en public où le mettre dans la même page de code que l'appel
IL faut le mettre en relation avec le boutopn, comme tu utilises un contrôle ActiveX, le code est bien placé dans le module de la feuille
bonjour Banzai64
merci de ta vue pour le manque du "t"
L faut le mettre en relation avec le bouton, comme tu utilises un contrôle ActiveX, le code est bien placé dans le module de la feuille
le code des boutons active x qui sont sur la feuille ont leurs codes dans le module Mgestion il n'y a que celui su sous total dans la feuille, car je l'ai mal ajouté et ne fonctionnait pas comme les autres
et pour ne pas ajouter de boutons il faudrait que l'enregistrement se fasse en même temps que le devis où factures
voici le code de la procédure d'enregistrement dont est issu une modification faite par toi
Private Sub CB_EnregistreDansLaBase_Click()
'procédure enregistrement sous PDF rectifié par BrunoM45 de excel-vba
Dim NomFicXL As String, CheminXL As String
Dim NomFicPDF As String, CheminPDF As String
Dim DLig As Long
Dim shp As Shape
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Sheets(WS_FACTURE)
If Sht.Range("IS_DOC_SAVED_IN_BASE") Then
UpdateTitre Sht.Range("DOC_TYPE")
End If
Sht.Range("IS_DOC_SAVED_IN_BASE") = True
DLig = Sht.Range("C" & Rows.Count).End(xlUp).Row
Dim NomDeFichier As String
NomDeFichier = Sht.Range("DOC_TITRE").Value & " - " & Sht.Range("DOC_CLIENT").Value
NomFicXL = NomDeFichier & ".xlsm"
NomFicPDF = NomDeFichier & ".pdf"
' Pour vérification de la valeur
Select Case UCase(Sht.Range("DOC_TYPE").Value)
Case DOC_DEVIS: CheminXL = DIR_DEVIS
Case DOC_FACT: CheminXL = DIR_FACT
Case DOC_FACT_AQUI: CheminXL = DIR_FACT_AQUI
Case DOC_FACT_ACC: CheminXL = DIR_FACT_ACC
Case Else
MsgBox "Erreur pour trouver le chemin de " & Sht.Range("D1").Value
Exit Sub
End Select
CheminPDF = CheminXL & "PDF\"
CheminXL = CheminXL & "\"
' Sauvegarder le classeur actif dans le chemin et le nom determiné
' FileFormat:=xlExcel8,
ActiveWorkbook.SaveAs Filename:=DIR_WORKSPACE & CheminXL & NomFicXL, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'SetButtonsVisible True
'**********************************************************************************
With Sht
.Activate
'code a tester et a supprimer si encore probleme
With .PageSetup
DLig = Range("suivant").Row
'MsgBox DerLig
.PrintArea = "C1:M" & DLig 'Sh.UsedRange.Rows.Count
'.PrintArea = ""
'la plage de cellules à imprimer pour chaque page
.PrintTitleRows = Sht.Range("C17:M18").Address
'.FitToPagesTall = 1
.FitToPagesWide = 1
.Orientation = xlPortrait
.PrintHeadings = False
' "pied de page au centre"
.CenterFooter = "&16&""Arial,Gras""SIRET : 482338738 - NAF : 4332A - RCS : 00032 - N° TVA : FR05482338738" & Chr(10) & _
"assurance décennale n°6507730304 de chez AXA"
End With
End With
'**********************************************************************************
' Exporter en PDF
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DIR_WORKSPACE & CheminPDF & NomFicPDF, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
SetButtonsVisible True
MsgBox "Votre sauvegarde porte la référence : " & " " & NomFicXL & vbCrLf _
& "Le fichier PDF à été créé sous le nom : " & NomFicPDF
' Fermer le classeur actif
'ActiveWorkbook.Close
'Sauvegarde les modifications
AjouteDocDansLaBase
With ThisWorkbook.Worksheets(WS_FACTURE).Range("DOC_TYPE")
If .Value = DOC_FACT Or .Value = DOC_FACT_AQUI Then
ConsommeLesArticlesDansLaBaseArticles
End If
End With
If Sht.Range("DOC_TYPE") = DOC_FACT_ACC Then
Dim Client As InfoClient: GetClientInfos Client
Dim montant As Double
Dim paiement As InfoPaiement
GetHiddenPaiementInfoToWs ThisWorkbook.Worksheets(WS_FACTURE), paiement, montant
AjoutePaiementDansLaBase ThisWorkbook, Client, paiement, montant
AjouteFacturePayeDansLaBase DOC_FACT_ACC, ThisWorkbook
End If
If ThisWorkbook.Worksheets(WS_FACTURE).Range("Totaltva10") > 0.0001 And _
ThisWorkbook.Worksheets(WS_FACTURE).Range("DOC_TYPE") <> DOC_DEVIS Then
DoAttestation7Percent
End If
Me.Hide
End SubPascal