[VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

R@chid

XLDnaute Barbatruc
Bonsoir tout le monde,
Ce R@chid ne va pas cesser de poser les question ??
:p:eek: Non je ne vais pas cesser..

Comme vous allez voir sur le fichier joint, ( mes amis sur le forum m'ont beaucoup aidé à le faire ), je peux créer un nouveau devis sur un nouvel onglet, imprimer les devis après filtre, récupérer les montants TTC et HT des nouveaux devis, mais le problème avec les devis sur le même fichier c'est que après un certain temps il y aura un problème de ralentissement de fichier avec 200 ou 300 devis, alors je me demande si on peut faire la même chose mais cette fois avec des devis sur un fichier chacun donc à la place de créer un nouvel onglet, créer un nouveau classeur avec un seul onglet (Onglet et Classeur portant le même nom) tout en gardant la possibilité d'imprimer ces classeurs après filtres et en récupérant les montant TTC/HT après l'enregistrement de ces derniers..

Je pense que j'ai appris à rédiger les questions ;)

@ + +
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonsoir R@chid,

Brut de fonderie sur ton fichier, en ayant juste modifié la macro existante :

Code:
Sub AjoutDevis()
  Dim Ind As Integer, LigSel As Long, NomSht As String
  Dim ShtTdB As Worksheet, TestSht As Worksheet
  Set ShtTdB = Sheets("TableauDeBord")
  LigSel = Selection.Row
  For Ind = 1 To 4
    If ShtTdB.Cells(LigSel, 1 + Ind).Value = "" Then
      MsgBox "Le devis ne peut pas être créé, il manque une information" _
       , vbExclamation, "Attention..."
      ShtTdB.Cells(LigSel, 1 + Ind).Select
      Exit Sub
    End If
  Next Ind
  NomSht = Range("A" & LigSel)
  With Sheets("Vierge (2)")
    .Visible = True
    .Copy 'nouveau document
    .Visible = False
  End With
  With ActiveWorkbook.Sheets(1)
    On Error Resume Next 'pour diverses raisons...
    .Name = NomSht
    .Range("J1").Value = NomSht
    .Range("J2").Value = ShtTdB.Range("B" & LigSel)
    .Range("B1").Value = ShtTdB.Range("C" & LigSel)
    .Range("B2").Value = ShtTdB.Range("D" & LigSel)
    .Range("H44").Value = ShtTdB.Range("E" & LigSel)
    .Parent.SaveAs ThisWorkbook.Path & "\" & NomSht
  End With
End Sub
A+
 

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonsoir @ tous,
Salut Job100%:eek:

Merci pour cette 1ère Macro, une petite astuce à adapter sur cette dernière il faut qu'elle vérifie l'existence du devis dans le dossier avant de le créer comme sa précédente pour le devis sur un nouvel onglet..

Et Merci de voir les autres macros :
- Worksheet_BeforeDoubleClick [Qui permet d'aller voir le devis]
- ImpressionDevis() [Imprimer les devis affichés après le filtre]
- Worksheet_Activate() [la tienne qui recupere les montants TTC/HT]

@ + +
 

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour R@chid,

Dans le fichier joint j'ai complété toutes les macros.

La plus intéressante est celle-ci :

Code:
Private Sub Worksheet_Activate()
Dim chemin As String, tablo, i As Long, fich As String
chemin = ThisWorkbook.Path & "\" 'à adapter
tablo = Range("A3:J" & Range("A" & Rows.Count).End(xlUp).Row)
For i = 1 To UBound(tablo)
  fich = Dir(chemin & tablo(i, 1) & ".xls*")
  tablo(i, 9) = "": tablo(i, 10) = ""
  If fich <> "" Then
    tablo(i, 9) = "=VLOOKUP(""*TTC*"",'" & chemin & "[" & fich & "]" & fich & "'!A1:J200,10,0)"
    tablo(i, 10) = "=VLOOKUP(""*HT*"",'" & chemin & "[" & fich & "]" & fich & "'!A1:J200,10,0)"
  End If
Next
Application.EnableEvents = False
[I3].Resize(UBound(tablo)).Formula = Application.Index(tablo, , 9)
[J3].Resize(UBound(tablo)).Formula = Application.Index(tablo, , 10)
[I3].Resize(UBound(tablo), 2) = [I3].Resize(UBound(tablo), 2).Value 'supprime les formules
Application.EnableEvents = True
End Sub
On remarquera qu'il n'est pas nécessaire d'ouvrir les fichiers Devis.

A+
 

Fichiers joints

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour @ tous,
Salut Job75 :)
Je tiens d'abord à te remercier pour le fichier c'est Impec.. :eek:
- Creation Devis OK
- Impression OK
- Double-cliquer pour Ouvrir OK
Une petite remarque que je ne peux pas voir d’où vient-elle,
Job75.png
Ici il me récupère les montants du 1er devis sur toute les 2 colonnes et voilà ma grande expérience en VBA ne me permet pas de corriger..

Une question subsidiaire, comment je peux définir moi même le dossier où l'on crée les devis ??

@ te lire
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,

Je ne vois pas comment tu peux obtenir ces résultats, joins ton fichier.

Quant à moi sur Excel 2003, avec la disposition en tableau, chaque activation de la feuille ajoute une ligne vide.

J'ai donc rajouté :

Code:
derlig = Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & derlig) = "" Then derlig = derlig - 1
tablo = Range("A3:J" & derlig)
Fichier (2).

A+
 

Fichiers joints

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour Job75,

Je ne vois pas comment tu peux obtenir ces résultats, joins ton fichier.
Je n'ai pas copié les macros sur un autre classeur, je travaille avec le fichier que j'ai téléchargé maintenant sur le forum..

Malgré la modification apportée le problème persiste encore..

Peut-être parce que je travaille sur XL2010, il me crée les nouveaux devis au format *.xlsx :confused:

@ + +
 

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,

Je viens de tester sur Excel 2010 et effectivement ça ne va pas du tout.

Je pense que c'est dû au fait qu'il s'agit d'une disposition en tableau.

La seule solution que j'ai trouvée est de remplir les cellules une par une :

Code:
Private Sub Worksheet_Activate()
Dim chemin As String, derlig As Long, P As Range, i As Long, fich As String
chemin = ThisWorkbook.Path & "\" 'à adapter
derlig = Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & derlig) = "" Then derlig = derlig - 1
Set P = Range("A3:A" & derlig)
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To P.Count
  fich = Dir(chemin & P(i) & ".xls*")
  P(i, 9).Resize(, 2).ClearContents
  If fich <> "" Then
    P(i, 9) = "=VLOOKUP(""*TTC*"",'" & chemin & "[" & fich & "]" & fich & "'!A1:J200,10,0)"
    P(i, 10) = "=VLOOKUP(""*HT*"",'" & chemin & "[" & fich & "]" & fich & "'!A1:J200,10,0)"
  End If
Next
[I3].Resize(i - 1, 2) = [I3].Resize(i - 1, 2).Value 'supprime les formules
Application.EnableEvents = True
End Sub
C'est bien sûr beaucoup plus long qu'avec un tableau VBA.

Fichier (3).

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,

Ah mais non, il suffit de calculer les formules par ExecuteExcel4Macro :

Code:
Private Sub Worksheet_Activate()
Dim chemin As String, derlig As Long, tablo, i As Long, fich As String
chemin = ThisWorkbook.Path & "\" 'à adapter
derlig = Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & derlig) = "" Then derlig = derlig - 1
tablo = Range("A3:J" & derlig)
For i = 1 To UBound(tablo)
  fich = Dir(chemin & tablo(i, 1) & ".xls*")
  tablo(i, 9) = "": tablo(i, 10) = ""
  If fich <> "" Then
    tablo(i, 9) = ExecuteExcel4Macro("VLOOKUP(""*TTC*"",'" & chemin & "[" & fich & "]" & tablo(i, 1) & "'!R1C1:R200C10,10,0)")
    tablo(i, 10) = ExecuteExcel4Macro("VLOOKUP(""*HT*"",'" & chemin & "[" & fich & "]" & tablo(i, 1) & "'!R1C1:R200C10,10,0)")
  End If
Next
Application.EnableEvents = False
[I3].Resize(i - 1).Formula = Application.Index(tablo, , 9)
[J3].Resize(i - 1).Formula = Application.Index(tablo, , 10)
Application.EnableEvents = True
End Sub
Fichier (4).

Avec des trucs comme ça tu vas devenir un crac R@chid :)

A+
 

Fichiers joints

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour,
Merci Job75 :), ça marche parfaitement maintenant.. (le MERCI n'est pas suffisant)
Pour l'autre question, mais juste si tu voie que je peux faire les modifications facilement, car après cette modification il faut refaire les 2 autres macros qui sont :
- Worksheet_BeforeDoubleClick
- Worksheet_Activate

Ce que je veux c'est de pouvoir spécifier le dossier où l'on peut créer les devis, donc il faut modifier le chemin sur AjoutDevis() comme il faut le modifier systématiquement sur les 2 autres..


@ + +

Edit : Ouppssssss je viens de voir l'autre réponse.. je test :)
 

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,

En fait ce n'est pas une Worksheet_Activate qu'il faut mais une Workbook_Activate dans ThisWorkbook :

Code:
Private Sub Workbook_Activate()
Dim chemin As String, derlig As Long, tablo, i As Long, fich As String
Sheets("TableauDeBord").Activate
chemin = Me.Path & "\" 'à adapter
derlig = Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & derlig) = "" Then derlig = derlig - 1
tablo = Range("A3:J" & derlig)
For i = 1 To UBound(tablo)
  fich = Dir(chemin & tablo(i, 1) & ".xls*")
  tablo(i, 9) = "": tablo(i, 10) = ""
  If fich <> "" Then
    tablo(i, 9) = ExecuteExcel4Macro("VLOOKUP(""*TTC*"",'" & chemin & "[" & fich & "]" & tablo(i, 1) & "'!R1C1:R200C10,10,0)")
    tablo(i, 10) = ExecuteExcel4Macro("VLOOKUP(""*HT*"",'" & chemin & "[" & fich & "]" & tablo(i, 1) & "'!R1C1:R200C10,10,0)")
  End If
Next
Application.EnableEvents = False
[I3].Resize(i - 1).Formula = Application.Index(tablo, , 9)
[J3].Resize(i - 1).Formula = Application.Index(tablo, , 10)
Application.EnableEvents = True
End Sub
Fichier (5).

Pour ta dernière question (dossier des devis), il suffit de remplacer ThisWorkbook.Path ou Me.Path par le chemin d'accès du dossier.

Là tu dois arriver à le faire tout seul.

A+
 

Fichiers joints

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,
En fait ce n'est pas une Worksheet_Activate qu'il faut mais une Workbook_Activate dans ThisWorkbook
Ok merci, je l'ai remarqué et j'ai pensé de me débrouiller tout seul après, mais bon tu es toujours là, ils sont très chanceux tes fils..

Pour ta dernière question (dossier des devis), il suffit de remplacer ThisWorkbook.Path ou Me.Path par le chemin d'accès du dossier.
Merci je vais essayer de le faire ce soir incha'allah :) :eek:

@ + +
 

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,
C'est cool, avec le 1er fichier j'avais un problème lors de la suppression des lignes du tableau ou quand on efface quelques données, mais maintenant c'est bon aucun bug :D
cool-smiley.jpg
Merci Merci
 

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonsoir @ tous,
Bonsoir Job75,
Merci pour ton aide précieuse, c'est impeccable..
Maintenant, je peux faire 2 onglets sur mon classeur, 1 pour les devis et l'autre pour les factures, et contrôler le tout depuis un seul classeur et tout cela grâce à vous mes amis.
Merci encore, et soyez à l'attente d'autres questions.

@ + +
 

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonsoir,
Ahhhhhhh :)
Est-il possible d'ajouter un truc sur cette macro,
Code:
Sub AjoutDevis()
  Dim Ind As Integer, LigSel As Long, NomSht As String
  Dim ShtTdB As Worksheet, fich As String
  Set ShtTdB = Sheets("TB_DEVIS")
  LigSel = Selection.Row
  For Ind = 1 To 4
    If ShtTdB.Cells(LigSel, 1 + Ind).Value = "" Then
      MsgBox "Le devis ne peut pas être créé, il manque une information" _
       , vbExclamation, "Attention..."
      ShtTdB.Cells(LigSel, 1 + Ind).Select
      Exit Sub
    End If
  Next Ind
  NomSht = Range("A" & LigSel)
  fich = "C:\Documents and Settings\R@chid\Bureau\DEVIS_FACTURES" & "\" & NomSht
  If Dir(fich & ".xls*") <> "" Then _
    MsgBox "Le devis a déjà été créé...": Exit Sub
  For Ind = 1 To Len(NomSht)
    If InStr("][\/:*?""<>|", Mid(NomSht, Ind, 1)) Then _
      MsgBox "Les caractères  ][\/:*?""<>| sont interdits...": Exit Sub
  Next
  With Sheets("DEVIS_V")
    .Visible = True
    .Copy
    .Visible = False
  End With
  With ActiveWorkbook.Sheets(1)
    .Name = Left(NomSht, 31)
    .Range("J1") = NomSht
    .Range("J2") = ShtTdB.Range("B" & LigSel)
    .Range("B1") = ShtTdB.Range("C" & LigSel)
    .Range("B2") = ShtTdB.Range("D" & LigSel)
    .Range("H44") = ShtTdB.Range("E" & LigSel)
    .Parent.SaveAs fich
  End With
End Sub
Ça bug quand le classeur est protégé, je veux que je puisse le faire fonctionner malgré la protection du classeur.

@ te relire
 

Victor21

XLDnaute Barbatruc
Supporter XLD
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour, R@chid.

Peut-être la protection par macro avec le paramètre "userinterfaceonly"
Attendons la réponse de plus calé que moi en VBA...
:)
 

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,
Salut l'ami :)
Ok, merci pour ton passage
Quand est ce que l'on va apprendre le VBA ???
J'ai perdu beaucoup de temps sur les formules :rolleyes::eek:

@ + +
 

Victor21

XLDnaute Barbatruc
Supporter XLD
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,

Je ne pense pas que ce soit du temps perdu :cool:
Essaie :

VB:
...
Wiith ActiveWorkbook.Sheets(1)
.Unprotect
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:=True, _
                 UserInterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
    .Name = Left(NomSht, 31)
       .Range("J1") = NomSht
    .Range("J2") = ShtTdB.Range("B" & LigSel)
    .Range("B1") = ShtTdB.Range("C" & LigSel)
    .Range("B2") = ShtTdB.Range("D" & LigSel)
       .Range("H44") = ShtTdB.Range("E" & LigSel)
    .Parent.SaveAs fich
  End With
...
 
Dernière édition:

R@chid

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Re,
Un bug,
Victor21.png

Oui c'est vrai, c'est pas un temps perdu.

@ + +
 

job75

XLDnaute Barbatruc
Re : [VBA] Nouveau devis sur un nouveau fichier et pas nouvel Onglet

Bonjour R@chid, Patrick, le forum,

Si c'est le classeur qui est protégé :

Code:
'---
ThisWorkbook.Unprotect "Rachid" 'mot de passe
With Sheets("DEVIS_V")
   .Visible = True
   .Copy
   .Visible = False
End With
ThisWorkbook.Protect "Rachid"
'---
En passant, j'ai créé un fichier à partir du fichier (5) avec 1000 lignes en colonne A.

La macro Workbook_Activate s'exécute en 4,5 secondes sur Win7 - Excel 2003.

A+
 

Discussions similaires


Haut Bas