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 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
| Option Explicit
Sub Affect_email()
' declaration de variables
Dim mDer As Long, i As Long
Dim mMail As String
Dim stFile As String
Dim mIc As String
Dim mChemin As Long
Dim Reponse As VbMsgBoxResult
' déclaration prévention des erreurs lors exécution
On Error GoTo Compl_Fx_err
'Effacement complet de la feuille Echeances_contrats
ActiveWorkbook.Sheets("Echeances_contrats").Select
Cells.Select
Selection.Clear
'Selection fichier via fenetre windows ouvrir
stFile = Application.GetOpenFilename
Reponse = MsgBox("Fichier sélectionné = " & stFile, vbQuestion + vbOKCancel, "Traitement fichier source")
If Reponse = 1 Then
Workbooks.Open (stFile)
Else: Affect_email ' Si choix ANNUL retour en début de procédure >>> Cela provoque le code 9 en fin de traitement
End If
'copie de la feuille complete dans la feuille de destination Echeances_contrats
Range("A1").Select
Range(Selection.End(xlToRight), Selection.End(xlDown)).Copy
'Selection du fichier de destination et collage
Workbooks("Avis_Fctr_V2_4_DP.xls").Activate
ActiveWorkbook.Sheets("Echeances_contrats").Select
Range("A1").PasteSpecial
' positionnement sur la feuille Mail_cli
ActiveWorkbook.Sheets("Mail_cli").Select
' repérage du tableau complet en dynamique pour nommage nom:complet
' la zone nommée servira ensuite pour établir la Fx Recherchev
Range("A2").Select
ActiveCell.CurrentRegion.Select
ActiveWorkbook.Names.Add Name:="Complet", RefersToR1C1:=Selection
' retour sur A1 sur
Range("A1").Select
' positionnement sur la feuille Echeances_contrats
ActiveWorkbook.Sheets("Echeances_contrats").Select
' repérage dernière ligne renseignée sur Echeances_contrats
mDer = ActiveSheet.UsedRange.Rows.Count
' nettoyage des cellules destinées aux calculs
Range("O2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
' complément formules de calcul dans Echeances_contrats
Range("I2").Select
For i = 2 To mDer
Cells(i, 9).Select 'positionnement dynamique sur numéro de client dans Echeances_contrats
ActiveCell.Offset(0, 6).Formula = Application.WorksheetFunction.VLookup(Selection, Range("Complet"), 4, False) ' recherche et écriture mail client
ActiveCell.Offset(0, 7).Formula = Application.WorksheetFunction.VLookup(Selection, Range("Complet"), 5, False) ' recherche et écriture nom IC
ActiveCell.Offset(0, 8).Formula = Application.WorksheetFunction.VLookup(Selection, Range("Complet"), 6, False) ' recherche et écriture mail IC
ActiveCell.Offset(0, 9).Formula = Application.WorksheetFunction.VLookup(Selection, Range("Complet"), 7, False) ' recherche et écriture tel IC
Next
' message fin de traitement
MsgBox "Le tableau fins de contrats a été complété des adresses mail clients.", vbInformation + vbOKOnly, "Fin de traitement"
'Ecriture entête cellule O1 P1 Q1 R1 S1
Range("O1").Select
ActiveCell.Formula = "Courriel client"
Range("P1").Select
ActiveCell.Formula = "Nom IC"
Range("Q1").Select
ActiveCell.Formula = "Courriels IC"
Range("R1").Select
ActiveCell.Formula = "Tel IC"
Range("S1").Select
ActiveCell.Formula = "Commentaires manuels"
'mise en forme du tableau justification colonnes
Range("A1:S1").Font.Bold = True
ActiveSheet.Columns("A:S").Select
'selection.
Selection.EntireColumn.AutoFit
'retour sur A1 sur
Range("O2").Select
'FERMETURE DU FICHIER SELECTIONNE stFile
mChemin = Len(CurDir) + 2
stFile = Mid(stFile, mChemin, 50) ' permet de selectionner le seul nom du fichier avant de le fermer
Workbooks(stFile).Activate
ActiveWorkbook.Close False
Exit Sub
' gestion des erreurs rencntrées lors exécution
Compl_Fx_err:
' affiche le message erreur détectée (Mail non trouvé)
Select Case Err.Number
Case 1004
'MsgBox mMail & " ... INCONNU DANS LA BASE MAIL CLIENTS "
ActiveCell.Offset(0, 6).Formula = "INCONNU - A renseigner dans la base mail"
ActiveCell.Offset(0, 6).Font.ColorIndex = 3
Case Else
MsgBox Err.Description
End Select
' poursuite exécution de la procédure
Resume Next
End Sub |
Partager