Titre du sujet : Re: Test login et traitement
par myDearFriend! le 18/01/2010 22:34:44
Re,
Si j'ai bien compris la demande, tu peux remplacer le module de code par celui-ci :
Option Explicit
Private Function login() As String
login = Application.UserName
End Function
Sub InitOffre()
'myDearFriend! - www.mdf-xlpages.com
Dim Chemin As Variant
Dim Prenom As String, Nom As String, Tel As String, Fax As String
Dim Mail As String, Initiales As String, Ref As String
Dim N As Integer
Select Case login
Case "Jean.Dupont"
Prenom = "Jean"
Nom = "Dupont"
Tel = "0000000001"
Fax = "0000000002"
Mail = "jean.dupont@exemple.com"
Initiales = "JD"
Case "Guy.Martin"
Prenom = "Guy"
Nom = "Martin"
Tel = "1111111111"
Fax = "1111111112"
Mail = "guy.martin@exemple.com"
Initiales = "GM"
Case "Corinne.Jules"
Prenom = "Corinne"
Nom = "Jules"
Tel = "2222222221"
Fax = "2222222222"
Mail = "corinne.jules@exemple.com"
Initiales = "CJ"
Case "Claire.Chazal"
Prenom = "Claire"
Nom = "Chazal"
Tel = "3333333331"
Fax = "3333333332"
Mail = "claire.chazal@exemple.com"
Initiales = "CC"
Case Else
MsgBox "Login non répertorié"
End Select
If Prenom <> "" Then
With Sheets(1)
.Cells(11, 2).Value = Prenom & " " & Nom
.Cells(12, 2).Value = "Tél : " & Tel
.Cells(13, 2).Value = "Fax : " & Fax
'Détermine la réf de l'offre et met à jour les Cotations
Ref = Cotations(.Cells(8, 1).Value, .Cells(16, 12).Value, _
.Cells(11, 11).Value, Initiales) & "C"
.Cells(8, 9).Value = Ref & "/" & Initiales
End With
'Sauvegarde l'offre
Chemin = Application.GetSaveAsFilename(Ref, "Offres (*.xls), *.xls", _
, "Sauvegarde de l'offre...")
If Chemin <> False Then
ThisWorkbook.SaveAs Chemin
End If
End If
End Sub
Private Function Cotations(D As Date, Ste As String, Dest As String, _
Init As String) As String
'myDearFriend! - www.mdf-xlpages.com
Dim Ref As String
Dim L As Long
Dim N As Integer
Const Chemin As String = "V:\COTATIONS\COTATIONS 2010.xls"
Application.ScreenUpdating = False
With Workbooks.Open(Chemin)
With .Sheets(1)
'Num dernière ligne utilisée
L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Détermine nouvelle référence cotation
N = Val(Replace(.Cells(L, 1).Value, "2010-", "")) + 1
Ref = "2010-" & Format(N, "0000")
'Ajoute nouvelle ligne dans Cotations
.Cells(L + 1, 1).Value = Ref
.Cells(L + 1, 2).Value = D
.Cells(L + 1, 3).Value = Ste
.Cells(L + 1, 4).Value = Dest
.Cells(L + 1, 5).Value = Init
End With
'Sauve et ferme le fichier Cotations
.Close True
End With
Cotations = Ref
Application.ScreenUpdating = True
End Function
Attention, je n'ai mis aucun contrôle d'erreur dans ce code (cellules vides, Date en A8 mal saisie, etc....). A toi de gérer ces erreurs ou omissions éventuelles de l'utilisateur.
Cordialement,
Nb: merci d'utiliser la balise de Code pour insérer du Code VBA (ou même une formule) dans tes posts du forum.
Pour rappel :
|
Didier FOURGEOT