Bonjour,
Malheureusement, TOTO.form.????????????.987654321 ne fonctionne pas.
Voici mon code :
Sub index()
' Déclarations
Dim sLeChemin As String 'Chemin d'accès de ce classeur
Dim sFichierTravail As String 'Nom du fichier de travail
Dim bLeChoix As Boolean 'Indique si un des traitements a été sélectionné
Dim iClientEnCours As Double 'Compteur des relevés traités
Dim sNumClient As String 'N° de client
Dim erreur As Boolean 'Prend la valeur Vrai en cas de problème de chargement de fichiers
Dim Erreur_Cli As Boolean 'Erreur d'ouverture d'un relevé client
Dim Fic_Existe As String 'Nom du fichier xls du relevé
Dim Fichier_Fil As String 'Nom du fichier Excel sauvegardé
Dim Nom_Client As String 'Nom du client
Dim NomCla(10) As String 'Noms des classeurs contenant le détail des relevés à créer
Dim NbCli(10) As Double 'Nbre de relevés à créer pour chaque traitement
Dim NbTrait As Double 'Indique le nbre de traitements disponibles
Dim ligner As Double 'Ligne du client dans la feuille infos (cas MAJ)
Dim Ligne_info As Double 'Ligne du client dans la feuille infos (cas création)
Dim ligne As Double 'Ligne à utiliser dans la feuille Releves
Dim reste As Single 'Temps restant pour le traitement
Dim sText As String 'Message du progress bar
Dim sel As Double 'Compteur des traitements disponibles
Dim temps As Single 'Variable de calcul du temps restant de traitement
Dim Type_Groupement(10) As Boolean 'Indique si un traitement concerne des groupements
Dim ValeurPivot As String 'Valeur de pivot à utiliser dans la feuille de synthese
Dim vide As Boolean 'Indique si le relevé du client est vide
Dim iDerLigne As Double 'Compteur de la derniere ligne du tableau des groupements
Dim I As Double 'Cpt de boucle FOR
'Initialisation du Chemin d'accès de ce classeur
Let sLeChemin = ThisWorkbook.Path
Let sFichierTravail = ActiveWorkbook.Name
Le_User = UCase(InputBox _
(Prompt:="Veuillez indiquer le user qui a executé le traitement sous BORA / LORA / NORA", _
Title:="Relevés Excel", default:=Le_User))
Le_ID = UCase(InputBox _
(Prompt:="Veuillez indiquer votre ID :", _
Title:="Relevés Excel", default:=Le_ID))
'Si pas de user ou bouton annuler, on sort
If Le_User = "" Then Exit Sub
'Recherche du fichier de destruction des fichiers temporaires Explorer
'Fic_Existe = Dir("Z:\DEL.BAT")
Fic_Existe = Dir("D:\Documents and Settings" & Le_User & "\My Documents\DEL.BAT")
If Fic_Existe = "" Then ' Si il n'existe pas, on le créé
'Open "Z:\DEL.BAT" For Append As #1
Open "D:\Documents and Settings" & Le_User & "\My Documents\DEL.BAT" For Append As #1
'Print #1, "del /Q/S ""Z:\WINDOWS\Temporary Internet Files\*.*"""
Print #1, "del /Q/S ""D:\Documents and Settings" & Le_User & "\WINDOWS\Temporary Internet Files\*.*"""
Close #1
End If
'Solution retenue car les chargement FTP sont conservés en permanence sans MAJ possible
'Donc on supprime avant pour charger ensuite
'Shell "Z:\DEL.BAT", 0 ' Lancement de la suppression des fichiers temporaires
Shell "D:\Documents and Settings" & Le_User & "\My Documents\DEL.BAT", 0
Application.ScreenUpdating = False
Application.StatusBar = "Chargement des traitements de : " & Le_User
erreur = False
On Error GoTo erreur_ouverture ' Si le premier fichier de relevés est introuvable
'Workbooks.OpenText Filename:=Chemin_Reseau & "RELEVE0_" & Le_User
Workbooks.OpenText Filename:=Chemin_Reseau & "/" & "LGEMIREPEX.form.*" & "." & Le_ID
'Workbooks.OpenText Filename:=Chemin_Reseau & "LGEMIREPEX.form.*." & Le_ID
On Error GoTo 0
'Nbre de relevés
NbCli(0) = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Rows.Count - 1
'Nom du classeur
NomCla(0) = ActiveWorkbook.Name
'Recherche si groupement
If InStr(1, Cells(1, 1), "GROUPEMENT") > 0 _
Then Type_Groupement(0) True Else Type_Groupement(0) False
'MAJ de la boite de dialogue
BD_Releves.Traitements.Clear
'Si plus d'un client dans ce traitement
If NbCli(0) > 2 Then
BD_Releves.Traitements.AddItem Cells(1, 1) & " Multiple"
Else
BD_Releves.Traitements.AddItem Cells(1, 1) & " " & Cells(2, 1)
End If
'On boucle sur les 9 autres traitements possibles
For I = 1 To 9
'Si un fichier de relevés est introuvable
On Error GoTo erreur_Classeur
Workbooks.OpenText Filename:=Chemin_Reseau & "LGEMIREPEX.form.*" & "." & Le_ID
'Workbooks.OpenText Filename:=Chemin_Reseau & "LGEMIREPEX.form.*" & Le_ID
On Error GoTo 0
' Erreur, donc pas d'autres traitements disponibles
If erreur = True Then Exit For
'Nbre de relevés
NbCli(I) = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Rows.Count - 1
'Nom du classeur
NomCla(I) = ActiveWorkbook.Name
'Recherche si groupement
If InStr(1, Cells(1, 1), "GROUPEMENT") > 0 _
Then Type_Groupement(I) True Else: Type_Groupement(I) False
If NbCli(I) > 2 Then ' Si plus d'un client dans ce traitement
BD_Releves.Traitements.AddItem Cells(1, 1) & " Multiple"
Else
BD_Releves.Traitements.AddItem Cells(1, 1) & " " & Cells(2, 1)
End If
Next
'MAJ de la boite de dialogue
BD_Releves.CODE_USER = Le_User
'Affichage de la boite de dialogue du choix des traitements
La_Reponse = False
ThisWorkbook.Activate
Application.StatusBar = "Sélection des traitements à charger..."
Application.ScreenUpdating = True
'On boucle tant qu'il n'y a pas de sélection
Do
BD_Releves.Show
'On sort si sélection du bouton 'Annuler'
If La_Reponse = False Then
Application.StatusBar = False
'On ferme tous les classeurs de relevés
On Error Resume Next ' On ne fait rien si il n'y pas de classeur
For I = 0 To 9
Workbooks(NomCla(I)).Close
Next
Exit Sub
End If
bLeChoix = False
'Nbre de traitements disponibles
NbTrait = BD_Releves.Traitements.ListCount
'On cherche si au moins un traitement est sélectionné
For sel = 0 To NbTrait - 1
If BD_Releves.Traitements.Selected(sel) True Then bLeChoix True
Next
'Fin de boucle si sélection de traitement
Loop While bLeChoix = False
'On compte le nbre de relevés à traiter
For sel = 0 To NbTrait - 1
If BD_Releves.Traitements.Selected(sel) = True Then
Total_Cli = Total_Cli + NbCli(sel)
End If
Next
'Macro d'objet progress Bar
Workbooks.Open Filename:=sLeChemin & "\WKSPRGRS.XLA"
Application.ScreenUpdating = False
temps = Timer ' Calcul du temps de traitement
'Corps du programme de génération des relevés
For sel = 0 To NbTrait - 1 ' Pour chaque traitement
If BD_Releves.Traitements.Selected(sel) = True Then ' Si il est sélectionné
'On boucle tant qu'il reste des relevés
ligne = 2
'NomCla(sel) est le nom du REPEX
Do While Workbooks(NomCla(sel)).Sheets(1).Cells(ligne, 1) <> ""
iClientEnCours = iClientEnCours + 1
'sNumClient = Format(Workbooks(NomCla(sel)).Sheets(1).Cells(ligne, 1), "0000000")
sNumClient = Format(Workbooks(NomCla(sel)).Sheets(1).Cells(ligne, 1), "0000000")
' MsgBox (sNumClient)
' Affichage de la progression du traitement
Application.StatusBar = "Chargement du relevé client : " & sNumClient
'Calcul du temps restant à partir du 5ème relevé
If iClientEnCours > 4 Then
reste = (Timer - temps) / iClientEnCours * (Total_Cli - iClientEnCours)
sText = "Veuillez patienter !" & Chr(20) & _
"Traitement du client : " & sNumClient & Chr(10) & _
"Temps restant estimé : " & TimeSerial(0, 0, Int(reste))
Else
sText = "Veuillez patienter !" & Chr(20) & _
"Traitement du client : " & sNumClient
End If
'Affichage du message
Application.Run "WKSPRGRS.XLA!ProgressShow"
'Texte centré
Application.Run "WKSPRGRS.XLA!ProgressSetText", sText, "C"
'% du progress bar
Application.Run "WKSPRGRS.XLA!ProgressSetValue", iClientEnCours, Total_Cli
Erreur_Cli = False
' Création du relevé
On Error GoTo err_ouverture_client
Workbooks.OpenText Filename:=Chemin_Reseau & "LGEMICUSTEX.form.201110281446." & Le_ID & "." & sNumClient, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 2), Array(4, 4), Array(5, 4), Array(6, 4), Array(7, 4))
'FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 2))
On Error GoTo 0
If Erreur_Cli = False Then ' Si il n'y a pas d'erreur, on traite le relevé
vide = False
If (Cells(1, 1) "FICHIER VIDE") Or (Cells(1, 1) "EMPTY FILE") Then vide = True ' Relevé vide
If vide = False Then ' Si le relevé n'est pas vide, on le génère
' Mise en forme du relevé
'-------------------------
ActiveWindow.DisplayGridlines = False
Range(PREM_COL & PREM_LG_BLOC_CLIENT & ":" _
& PREM_COL & DER_LG_BLOC_CLIENT).Cut _
Destination:=Range(COL_NUM_MVT & PREM_LG_BLOC_CLIENT & ":" _
& COL_NUM_MVT & DER_LG_BLOC_CLIENT)
Columns(PREM_COL).Delete Shift:=xlToLeft
Range(PREM_COL & PREM_LG_BLOC_CLIENT & ":" & PREM_COL & NOM_ETAT) _
.Font.Bold = True
Range(PREM_COL & PREM_LG_BLOC_CLIENT & ":" & DER_COL & NOM_ETAT) _
.Font.Size = 11
'Mise en forme de la ligne d'entete
Rows(LG_ENTETE_COL).HorizontalAlignment = xlCenter
'Mise en forme des colonnes de montant
Columns(COL_MT_INITIAL & ":" & DER_COL) _
.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
ActiveSheet.PageSetup.PrintTitleRows = "$9:$9"
With ActiveSheet.PageSetup
.Zoom = False
.RightHeader = "&P/&N"
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Nom_Client = Range(PREM_COL & LG_NOM_CLIENT)
'Mise en forme des colonnes
Columns(COL_NUM_MVT).HorizontalAlignment = xlLeft
With Columns(COL_DATE_ECHEANCE)
.NumberFormat = "dd/mm/yy"
.HorizontalAlignment = xlCenter
End With
Columns(COL_DEVISE).HorizontalAlignment = xlCenter
With Columns(COL_DATE_TRANSACT)
.NumberFormat = "dd/mm/yy"
.HorizontalAlignment = xlCenter
End With
Columns(PREM_COL & ":" & DER_COL).Columns.AutoFit
Columns(PREM_COL).ColumnWidth = 8.22
Columns(COL_DEVISE).ColumnWidth = 7
Range(PREM_COL & LG_NOM_CLIENT & ":" & PREM_COL & DER_LG_BLOC_CLIENT) _
.Cut _
Destination:=Range(COL_NOM_CLIENT_FIN & LG_FINALE_NOM_CLIENT & ":" _
& COL_NOM_CLIENT_FIN & LG_FINALE_INFO_CLIENT)
Rows(DER_LG_BLOC_CLIENT).Delete Shift:=xlUp
Range(COL_NOM_CLIENT_FIN & LG_FINALE_NOM_CLIENT).Font.FontStyle = "Gras"
With Range(PREM_COL & LG_ENTETE_COL & ":" & DER_COL & LG_ENTETE_COL) _
.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range(COL_MT_INITIAL & LG_ENTETE_COL & ":" & DER_COL & LG_ENTETE_COL) _
.HorizontalAlignment = xlRight
'Changement des noms de colonnes
'--------------------------------
'Quand la colonne de date d'echeance est en francais alors la changer
If Range(COL_DATE_ECHEANCE & LG_ENTETE_COL) = TEXT_DAT_ECHE_INIT _
Then Range(COL_DATE_ECHEANCE & LG_ENTETE_COL) = TEXT_DAT_ECHE
'Changement de la colonne EURO
Range(DER_COL & LG_ENTETE_COL) = TEXT_MTT_EURO
Columns(DER_COL).AutoFit
Range(PREM_COL & PREM_LG_BLOC_CLIENT).Select
'Pour les groupementS uniquement
'----------------------------------
If Type_Groupement(sel) = True Then
'Copie de la feuille de données avec nouveau nom
Creation_Feuille_Donnees_Groupement _
ActiveWorkbook.Name, ActiveSheet.Name
'Mise en forme des colonnes dans la feuille
Mise_Forme_Feuille_Groupement ActiveWorkbook.Name
'Identification de la derniere ligne des données
iDerLigne = Determination_Derniere_Ligne(ActiveWorkbook.Name)
'Duplication de la détermination de typologie sur tout le tableau
'If iDerLigne > LG_PREM_DETAIL
'Then Range(COL_TYPE_PROD_GRPMT & LG_PREM_DETAIL).AutoFill _
' Destination:=Range(COL_TYPE_PROD_GRPMT & LG_PREM_DETAIL & ":" _
'& COL_TYPE_PROD_GRPMT & iDerLigne)
'Range(COL_TYPE_PROD_GRPMT & LG_PREM_DETAIL & ":" _
' & COL_TYPE_PROD_GRPMT & iDerLigne).Copy
'Range(COL_TYPE_PROD_GRPMT & LG_PREM_DETAIL & ":" _
' & COL_TYPE_PROD_GRPMT & iDerLigne).PasteSpecial _
'Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, _
'Transpose:=False
'Lissage du format sur toute la colonne
'With Range(PREM_COL & LG_ENTETE_COL & ":" _
' & COL_SOLDE_DEV_GRPMT & LG_ENTETE_COL).Borders(xlEdgeBottom)
' .LineStyle = xlContinuous
' .Weight = xlThin
' .ColorIndex = xlAutomatic
' End With
Range(PREM_COL & PREM_LG_BLOC_CLIENT).Select
'Creation d'une synthèse du compte en tableau croise
Creation_Tableau_synthese sFichierTravail, ActiveWorkbook.Name, _
iDerLigne
End If
'Recherche du fichier XLS
Fic_Existe = Dir(sLeChemin & "\Releves" & sNumClient & ".xls")
'Si il existe, on le détruit
If Fic_Existe <> "" Then _
Kill sLeChemin & "\Releves" & sNumClient & ".xls"
'Sauvegarde au format Excel pour assurer une compatibilité avec les clients
ActiveWorkbook.SaveAs _
Filename:=sLeChemin & "\Releves" & sNumClient & ".xls", _
FileFormat:=xlNormal
Fichier_Fil = ActiveWorkbook.Name
End If
ActiveWorkbook.Close
ThisWorkbook.Sheets("Releves").Activate
'Recherche du client dans la feuille releves
Set motcherch = Columns(COL_NUM_MVT).Find(sNumClient, LookAt:=xlWhole)
'Si il existe, on le supprime
If Not motcherch Is Nothing Then Cells(motcherch.Row, 1).EntireRow.Delete
If Cells(4, 2) <> "" Then ' Si la première ligne est déjà remplie
I = Cells(3, 2).End(xlDown).Row + 1
Else
I = 4 ' première ligne
End If
'MAJ de la feuille Releves
Cells(I, 2) = sNumClient
'Si le relevé n'est pas vide, on indique le nom du client
If vide False Then Cells(I, 3) Nom_Client
'Recherche du client dans la feuille infos
Set motcherch = Sheets("infos").Columns(PREM_COL) _
.Find(sNumClient, LookAt:=xlWhole)
'Si le client existe, on met à jour la feuille releves
If Not motcherch Is Nothing Then
ligner = motcherch.Row
Cells(I, 1) = Sheets("infos").Cells(ligner, 3)
Cells(I, 4) = Sheets("infos").Cells(ligner, 4)
Cells(I, 7) = Sheets("infos").Cells(ligner, 5)
'Si le relevé n'est pas vide, on met à jour le nom du client
If vide = False Then
Sheets("infos").Cells(ligner, 2) = Nom_Client
Else
'On met le nom de infos dans la feuille releves
Cells(I, 3) = Sheets("infos").Cells(ligner, 2)
End If
'Si le client n'existe pas dans la feuille infos
Else
' On créé le client
' Si la première ligne est déjà remplie
If Sheets("infos").Cells(2, 1) <> "" Then
Ligne_info = Sheets("infos").Cells(1, 1).End(xlDown).Row + 1
Else
Ligne_info = 2 ' première ligne
End If
Sheets("infos").Cells(Ligne_info, 1) = sNumClient
' si le relevé n'est pas vide, on indique le nom du client
If vide = False Then
Sheets("infos").Cells(Ligne_info, 2) = Nom_Client
Else
Sheets("infos").Cells(Ligne_info, 2) = "Inconnu !"
End If
'Pas d'envoi d'Email auto en standard
Cells(I, 1) = "Non"
End If
'Si le relevé n'est pas vide on créé le lien hypertexte avec le relevé XLS
If vide = False Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 2), _
Address:=sLeChemin & "\Releves" & Fichier_Fil
Cells(I, 6) = Format(Date, "dd/mm/yy") ' Date de MAJ
Else
Cells(I, 5) = "Vide" ' Le relevé est vide, on le précise
Cells(I, 6) = Format(Date, "dd/mm/yy") ' Date de MAJ
End If
Else ' Il y a eu une erreur à l'ouverture du relevé sur le serveur
ThisWorkbook.Sheets("Releves").Activate
' Recherche du client dans la feuille releves
Set motcherch = Columns(COL_NUM_MVT).Find(sNumClient, LookAt:=xlWhole)
'Si il existe, on le supprime
If Not motcherch Is Nothing Then Cells(motcherch.Row, 1).EntireRow.Delete
If Cells(4, 2) <> "" Then ' Si la première ligne est déjà remplie
I = Cells(3, 2).End(xlDown).Row + 1
Else
I = 4 ' première ligne
End If
Cells(I, 2) = sNumClient
' Recherche du client dans la feuille infos
Set motcherch = Sheets("infos").Columns(PREM_COL) _
.Find(sNumClient, LookAt:=xlWhole)
' Si le client existe, on met à jour la feuille releves
If Not motcherch Is Nothing Then
ligner = motcherch.Row
Cells(I, 3) = Sheets("infos").Cells(ligner, 2)
End If
Cells(I, 1) = "Non"
Cells(I, 5) = "Erreur "
Cells(I, 6) = Format(Date, "dd/mm/yy") ' Date de MAJ
End If
ligne = ligne + 1 ' Ligne suivante
Loop
End If
' Workbooks(NomCla(sel)).Close
Next
'Fin d'utilisation de progressbar
Application.Run "WKSPRGRS.XLA!ProgressClear"
Columns(COL_NUM_MVT & ":" & COL_DEVISE).EntireColumn.AutoFit
Range(PREM_COL & LG_FINALE_NOM_CLIENT).Sort Key1:=Range(COL_NUM_MVT & LG_FINALE_TRIE), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Workbooks("WKSPRGRS.XLA").Close ' fermeture de la macro progress bar
'Fic_Existe = Dir("Z:\DEL.BAT") ' Recherche du fichier
Fic_Existe = Dir("D:\Documents and Settings" & Le_User & "\My Documents\DEL.BAT")
'If Fic_Existe <> "" Then Kill "Z:\DEL.BAT" ' Supression si il existe
If Fic_Existe <> "" Then Kill "D:\Documents and Settings" & Le_User & "\My Documents\DEL.BAT"
Stat ' procédure d'alimentation des statistiques
Application.StatusBar = False
Exit Sub
err_ouverture_client: ' Erreur d'ouverture d'un fichier client
Erreur_Cli = True
Resume Next
erreur_ouverture: ' Problème de connexion ou pas de traitement disponible
MsgBox Prompt:="connexion impossible ou pas de traitement disponible pour " & Le_User, _
Buttons:=vbCritical, Title:="Erreur d'ouverture"
Application.StatusBar = False
Exit Sub
erreur_Classeur:
erreur = True
Resume Next
End Sub
' ----------------------------------------------------------------------------------------
' Procédure : Stat
' Evénement : Appelée par la procédure index
' Rôle : Mise à jour du tableau des statistiques
' MAJ : 30/09/1999
' ----------------------------------------------------------------------------------------
Sub Stat()
On Error GoTo annule ' Ce traitement facultatif est annulé en cas d'erreur
Open Chemin_Stat & "\STAT" For Append As #1
Write #1, Le_User; Total_Cli; Date; Time
Close #1
Exit Sub
annule:
Close #1
Exit Sub
End Sub
' ----------------------------------------------------------------------------------------
' Procédure : SendMail
' Evénement : Appelée par le bouton 'Envoyer tous les relevés / mail' de la feuille
' Releves de ce classeur
' Rôle : Envoi automatique des mails
' MAJ : 30/09/1999
' ----------------------------------------------------------------------------------------
Sub SendMail()
' Déclarations
Dim reponse_mail As Double ' Variable du statut de la boite de dialogue
Dim ereur As Double ' Compteur des erreurs d'envoi
Dim nbr As Double ' Nombre de clients à traiter
Dim dest As String ' Destinataire du relevé
Dim sujet As String ' Objet du message envoyé
'
reponse_mail = MsgBox(Prompt:="Veuillez confirmer l'envoi des mails aux clients", _
Buttons:=vbQuestion + vbYesNo, Title:="Envoi des relevés par mail")
If reponse_mail = vbNo Then Exit Sub ' Demande de confirmation avant envoi
I = 4 ' premier client
ereur = 0
nbr = Cells(4, 2).CurrentRegion.Rows.Count - 1
'On boucle sur l'ensemble des clients présents dans la feuille releves
Do While Cells(I, 2) <> ""
'On envoi un mail en cas de statut à OUI pour un relevé
'qui n'est pas vide et comportant un Email
If UCase(Cells(I, 1)) = "OUI" And Trim(Cells(I, 4)) <> "" _
And Cells(I, 5) <> "Vide" Then
dest = Cells(I, 4)
sujet = Cells(I, 7)
Application.StatusBar = "Traitement en cours : " & Format((I - 3) / nbr, "0%") & " erreurs " _
& ereur & " sur " & I - 3 & " " & Cells(I, 3)
'On affiche le relevé
Cells(I, 2).Hyperlinks.Item(1).Follow
On Error GoTo Traiterr ' En cas d'erreur on le signale
ThisWorkbook.Sheets("Releves").Cells(I, 5) = "" ' On met à vide le statut
If sujet <> "" Then ' Envoi avec ou sans objet
ActiveWorkbook.SendMail Recipients:=dest, Subject:=sujet
Else
ActiveWorkbook.SendMail Recipients:=dest
End If
ActiveWorkbook.Close SaveChanges:=False ' On ferme le relevé
On Error GoTo 0
End If
I = I + 1 ' client suivant
Loop
Application.StatusBar = False
Exit Sub
Traiterr:
ThisWorkbook.Sheets("Releves").Cells(I, 5) = "ERREUR"
ereur = ereur + 1
Resume Next
End Sub
' ----------------------------------------------------------------------------------------
' Procedure : Send_Ce_Mail
' Evénement : Appelée par le bouton 'Envoyer ce relevé / mail' de la feuille
' Releves de ce classeur
' Rôle : Envoi d'un mail particulier - Celui présent dans la ligne de la cellule
' active
' MAJ : 30/09/1999
' ----------------------------------------------------------------------------------------
Sub Send_Ce_Mail()
' Déclarations
Dim dest As String ' Destinataire du relevé
Dim sujet As String ' Objet du message envoyé
'
I = ActiveCell.Row ' Ligne active
' On envoi un mail pour un relevé qui n'est pas vide et comportant un Email
If Trim(Cells(I, 4)) <> "" And Cells(I, 5) <> "Vide" Then
dest = Cells(I, 4)
sujet = Cells(I, 7)
Cells(I, 2).Hyperlinks.Item(1).Follow ' On affiche le relevé
On Error GoTo Traiterr ' En cas d'erreur on le signale
ThisWorkbook.Sheets("Releves").Cells(I, 5) = "" ' On met à vide le statut
If sujet <> "" Then ' Envoi avec ou sans objet
ActiveWorkbook.SendMail Recipients:=dest, Subject:=sujet
Else
ActiveWorkbook.SendMail Recipients:=dest
End If
ActiveWorkbook.Close SaveChanges:=False ' On ferme le relevé
On Error GoTo 0
End If
Exit Sub
Traiterr:
ThisWorkbook.Sheets("Releves").Cells(I, 5) = "ERREUR"
Resume Next
End Sub
'----------------------------------------------------------------------------
Sub Test()
Range("C9").FormulaR1C1 = _
"=IF(LEN(RC[-1])=9,""Verres"",IF(RIGHT(LEFT(RC[-1],2),1)=""6"",""Instruments"",""""))"
'"=IF(LEN(RC[-1])=9,""Verres"",IF(OR(LEFT(RC[-1],2)=""86"",LEFT(RC[-1],2)=""96"",LEFT(RC[-1],2)=""06"",LEFT(RC[-1],2)=""16"",LEFT(RC[-1],2)=""26""),""Instruments"",IF(OR(LEFT(RC[-1],2)=""80"",LEFT(RC[-1],2)=""90"",LEFT(RC[-1],2)=""91"",LEFT(RC[-1],2)=""00"",LEFT(RC[-1],2)=""01"",LEFT(RC[-1],2)=""10"",LEFT(RC[-1],2)=""11"",LEFT(RC[-1],2)=""21""),""Contacts"","""")))"
End Sub
'----------------------------------------------------------------------------
'Creation_Feuille_Donnees_Groupement
'Role : Creation d'une feuille de travail pour les groupements
'Entree : sNomFichierEnCours -> nom du fichier du groupement en cours
' sFeuilleSource -> feuille source de la copie
'Constante : FEUIL_DONNEES
'----------------------------------------------------------------------------
Sub Creation_Feuille_Donnees_Groupement(sNomFichierEnCours As String, _
sFeuilleSource As String)
Sheets(sFeuilleSource).Copy After:=Workbooks(sNomFichierEnCours).Sheets(1)
' Renomer la feuille
ActiveSheet.Name = FEUIL_DONNEES
End Sub
'----------------------------------------------------------------------------------
'Mise_Forme_Feuille_Groupement
'Role : Mise en forme de la feuille de travail pour les groupements
'Entree : sNomFichierGroupement -> nom du fichier du groupement en cours
'Constante : FEUIL_DONNEES,PREM_COL,LG_ENTETE_COL,COL_DATE_TRANSACT,
' COL_TYPE_PROD_GRPMT, LG_PREM_DETAIL
'----------------------------------------------------------------------------------
Sub Mise_Forme_Feuille_Groupement(sNomFichierGroupement As String)
'Activation de la feuille
Workbooks(sNomFichierGroupement).Sheets(FEUIL_DONNEES).Activate
'On remplace le terme "Compte"
Range(PREM_COL & LG_ENTETE_COL) = TEXT_ADH
'Columns(COL_DATE_TRANSACT).Insert Shift:=xlToRight
'Columns(COL_TYPE_PROD_GRPMT).NumberFormat = "General"
'On créé une rubrique pour indiquer le type de produits
'Range(COL_TYPE_PROD_GRPMT & LG_ENTETE_COL) = TEXT_TYP
'MAJ 31/01/00 et 03/03/00 Ajout des N° factures 2000, 2001
'Range(COL_TYPE_PROD_GRPMT & LG_PREM_DETAIL).FormulaR1C1 = _
'"=IF(LEN(RC[-1])=9,""Verres"",IF(RIGHT(LEFT(RC[-1],2),1)=""6"",""Instruments"",IF(LEFT(RC[-1],1)=""G"",""Montage"","""")))"
'"=IF(LEN(RC[-1])=9,""Verres"",IF(OR(LEFT(RC[-1],2)=""86"",LEFT(RC[-1],2)=""96"",LEFT(RC[-1],2)=""06"",LEFT(RC[-1],2)=""16""),""Instruments"",IF(OR(LEFT(RC[-1],2)=""80"",LEFT(RC[-1],2)=""90"",LEFT(RC[-1],2)=""91"",LEFT(RC[-1],2)=""00"",LEFT(RC[-1],2)=""01"",LEFT(RC[-1],2)=""10"",LEFT(RC[-1],2)=""11""),""Contacts"","""")))"
End Sub
'-----------------------------------------------------------------------------------
'Determination_Derniere_Ligne
'Role : Détermination de la derniere ligne du tableau avec suppression des sauts de
' ligne et de la ligne de sous total avant la ligne blanche
'
'Entree : sNomFichierGroupement -> nom du fichier du groupement en cours
'Constante : FEUIL_DONNEES,COL_NUM_MVT,LG_ENTETE_COL,COL_DEVISE,TEXT_SOUSTT
'-----------------------------------------------------------------------------------
Function Determination_Derniere_Ligne(sNomFichier As String) As Double
Dim iLaDerLigne As Double 'Derniere ligne du tableau
Dim rDerCellule As Range 'Derniere cellule en cours
Dim iLaLigneSupp As Double 'Derniere ligne du tableau
'Activation de la feuille
Workbooks(sNomFichier).Sheets(FEUIL_DONNEES).Activate
'Determination du 1er bloc
Let iLaDerLigne = Range(COL_NUM_MVT & LG_ENTETE_COL).End(xlDown).Row
Set rDerCellule = Range(COL_DEVISE & iLaDerLigne)
'Tant que 2 lignes au dessous non vide
While rDerCellule.Offset(5, 0) <> ""
'Supprimer les lignes suivantes 2 vides + 2 sous totaux
Let iLaLigneSupp = iLaDerLigne + 1
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
'Réinitialiser la derniere ligne
Let iLaDerLigne = Range(COL_NUM_MVT & LG_ENTETE_COL).End(xlDown).Row
Set rDerCellule = Range(COL_DEVISE & iLaDerLigne)
Wend
'Suppression des derniere ligne de totalisation non significatif
Let iLaLigneSupp = iLaDerLigne + 1
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Rows(iLaLigneSupp & ":" & iLaLigneSupp).Delete Shift:=xlUp
Let Determination_Derniere_Ligne = iLaDerLigne
End Function
'-----------------------------------------------------------------------------------
'Creation_Tableau_synthese
'Role : Creation du tableau dymanique croise sur les groupements
'
'Entree : sNomFichierGroupement -> nom du fichier du groupement en cours
' sNomFichierT -> nom du fichier de la macro en cours
'
'Constante : FEUIL_DONNEES,COL_SOLDE_DEV_GRPMT,LG_ENTETE_COL,PREM_COL,
' COL_SOLDE_DEV_GRPMT,TAB_NAME,PREM_LG_BLOC_CLIENT
'-----------------------------------------------------------------------------------
Sub Creation_Tableau_synthese(sNomFichierT As String, sNomFichierGrpt As String, _
iDerniereLgn As Double)
Dim iLongText As Double 'Longueur du texte des donnees
Dim iLongSomme As Double 'Longueur du texte somme
Dim rCelluleReste As Range 'Cellule de reste du
Dim rCelluleEuro As Range 'Cellule de l'Euro
Dim rCellDefTab As Range 'Tableau dyn
Dim iDerLigneTab As Double 'Dernière ligne du tableau dynamique
Dim iDerColTab As Double 'Dernière colonne du tableau dynamique
'Activation de la feuille
Workbooks(sNomFichierGrpt).Sheets(FEUIL_DONNEES).Activate
' Determination de la valeur pivot en fonction Anglais/Français
If Range(COL_SOLDE_DEVISE & LG_ENTETE_COL) = "Amount due remaining" Then
' Valeur pivot en Anglais
ValeurPivot = TEXT_RESTE_ANG
Else
ValeurPivot = TEXT_RESTE_FRF
End If
'Debute l'activation de la construction du tableau : definie la source
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
Range(PREM_COL & LG_ENTETE_COL & ":" & COL_SOLDE_DEVISE & iDerniereLgn), _
TableDestination:="", TableName:=TAB_NAME
'Definie les lignes et colonnes
ActiveSheet.PivotTables(TAB_NAME).AddFields RowFields:= _
Array("Date", "Devise"), ColumnFields:="Type"
'... avec la valeur de pivot
With ActiveSheet.PivotTables(TAB_NAME).PivotFields(ValeurPivot)
.Orientation = xlDataField
.Position = 1
.NumberFormat = "#,##0.00;[Red]-#,##0.00"
End With
' ... et le format des montants
'With ActiveSheet.PivotTables(TAB_NAME).PivotFields(TEXT_MTT_EURO)
' .Orientation = xlDataField
' .Position = 2
' .NumberFormat = "#,##0.00;[Red]-#,##0.00"
'End With
'
ActiveSheet.PivotTables(TAB_NAME).PivotSelect "Date[Tous]", xlLabelOnly
Selection.Group Start:=True, End:=True, _
Periods:=Array(False, False, False, False, True, False, True)
ActiveSheet.PivotTables(TAB_NAME).PivotSelect "Date[Tous]", xlLabelOnly
' Renomer la feuille
ActiveSheet.Name = TAB_NAME
' Definie la dimension du tableau en EURO
Set rCellDefTab = Sheets(TAB_NAME).Range("D3").CurrentRegion
Let iDerLigneTab = rCellDefTab.Rows.Count
Let iDerColTab = rCellDefTab.Columns.Count
'Coloriage Cells(iDerLigneTab, iDerColTab), 19
CreerColEURO sNomFichierT, sNomFichierGrpt, iDerLigneTab, iDerColTab
' Renomme la partie "Somme"
' Let iLongSomme = Len(TEXT_SOMME)
' Set rCelluleReste = Sheets(TAB_NAME).Range(CELL_RESTE_DU)
' Let iLongText = Len(rCelluleReste.Value)
' Let rCelluleReste.Value = Right(rCelluleReste.Value, iLongText - iLongSomme)
' Set rCelluleEuro = Sheets(TAB_NAME).Range(CELL_EURO)
' Let iLongText = Len(rCelluleEuro.Value)
' Let rCelluleEuro.Value = Right(rCelluleEuro.Value, iLongText - iLongSomme)
Range(PREM_COL & PREM_LG_BLOC_CLIENT).Select
End Sub
'-----------------------------------------------------------------------------------
'CreerColEURO
'Role : Creer la colonne en EURO
'
'Entree : sNomFichierTrav -> nom du fichier de la macro
' sNomFichierGroupement -> nom du fichier du groupement en cours
' iDerLgnTab -> dernière ligne du tableau dynamique
' iDerColTab -> dernière colonne du tableau dynamique
'
'Constante : FEUIL_DONNEES,COL_SOLDE_DEV_GRPMT,LG_ENTETE_COL,PREM_COL,
' COL_SOLDE_DEV_GRPMT,TAB_NAME,PREM_LG_BLOC_CLIENT, TEXT_SOMME
'-----------------------------------------------------------------------------------
Sub CreerColEURO(sFichierTrav As String, sNomFichGrpt As String, _
iDerLgnTab As Double, iDerColTab As Double)
Dim sgTauxConver As Single 'Taux de conversion recupere
Dim rCellDevise As Range 'Libelles de devise
Dim rCellEuro As Range 'Total Euro
Dim rCellTest As Range 'Zone d'identification de la ligne
Dim iColEuro As Double 'Colonne EURO
'Compteur pour determination des zone de sous.total
Dim iCptLigneInit As Double 'Position de la 1er ligne de bloc
Dim iLgnEncours As Double 'Position de la ligne en cours
Dim iCptLignMois As Double 'Cpt des mois traite
'Positionnement de la 1er cellule EURO
Set rCellEuro = Workbooks(sNomFichGrpt).Sheets(TAB_NAME). _
Cells(LG_1ER_DYN - 1, iDerColTab + 1)
Let iColEuro = rCellEuro.Column
Let rCellEuro.Value = TEXT_MTT_EURO
rCellEuro.HorizontalAlignment = xlCenter
rCellEuro.Offset(0, -1).HorizontalAlignment = xlCenter
'Initialisation des compteurs de ligne pour les sous totaux
Let iCptLigneInit = LG_1ER_DYN
Let iCptLignMois = 0
'Pour toute la hauteur du tableau
For iLgnEncours = LG_1ER_DYN To iDerLgnTab '+ 1
Set rCellTest = Workbooks(sNomFichGrpt).Sheets(TAB_NAME). _
Range(COL_TEST_DYN & iLgnEncours)
Set rCellEuro = Workbooks(sNomFichGrpt).Sheets(TAB_NAME). _
Cells(iLgnEncours, iColEuro)
'Si ce n'est pas une ligne de somme
Select Case Left(rCellTest.Text, 5)
'test si total mois
Case TEXT_SOMME
'faire un sous total avec libelle de sous.total(iCptLignMoisInit, iCptLignMois)
'Coloriage rCellEuro, 8
Let iCptLignMois = iCptLigneInit - iLgnEncours
Let rCellEuro.FormulaR1C1 = _
"=SUBTOTAL(9,R[" & iCptLignMois & "]C:R[-1]C)"
'Reinitialiser la 1er valeur du sous.total
Let iCptLigneInit = iLgnEncours + 1
'Si la cellule testee semble vide
Case ""
'Cas du total final
If Left(rCellTest.Offset(0, -1).Text, 5) = TEXT_SOUSTT Then
'faire le total général de LG_1ER_DYN a iCptLigne
'Coloriage rCellEuro, 16
Let iCptLignMois = LG_1ER_DYN - iLgnEncours
Let rCellEuro.FormulaR1C1 = _
"=SUBTOTAL(9,R[" & iCptLignMois & "]C:R[-2]C)"
'cas des 2nd et autres lignes mensuelles
Else
'Initialise la valeur de devise
Set rCellDevise = Workbooks(sNomFichGrpt).Sheets(TAB_NAME).Range(COL_DEVISE_DYN & iLgnEncours)
'Coloriage rCellDevise, 8
'Recherche la valeur du taux
Let sgTauxConver = RechercheTauxConversion(sFichierTrav, rCellDevise.Value)
'Converti le montant total
Let rCellEuro.Value = rCellEuro.Offset(0, -1) / sgTauxConver
'Coloriage rCellEuro, 8
End If
Case Else
'Initialise la valeur de devise
Set rCellDevise = Workbooks(sNomFichGrpt).Sheets(TAB_NAME).Range(COL_DEVISE_DYN & iLgnEncours)
'Coloriage rCellDevise, 8
'Recherche la valeur du taux
Let sgTauxConver = RechercheTauxConversion(sFichierTrav, rCellDevise.Value)
'Converti le montant total
Let rCellEuro.Value = rCellEuro.Offset(0, -1) / sgTauxConver
'Coloriage rCellEuro, 8
End Select
rCellEuro.NumberFormat = "#,##0.00;[Red]-#,##0.00"
Next
rCellEuro.Select
End Sub
'-----------------------------------------------------------------------------------
'RechercheTauxConversion
'Role : Recherche le taux de conversion
'
'Entree : sFicherW As String -> Nom du fichier de la macro
' sDevise -> Nom de la devise a rechercher
'
'Constante : FEUIL_TAUX,TAB_TAUX,COL_DEV_TAUX,COL_VAL_TAUX
'-----------------------------------------------------------------------------------
Function RechercheTauxConversion(sFicherW As String, sDevise As String) As Single
Dim rCellDevTrouvee As Range
Dim rCellValTaux As Range
'Trouver la ligne de la devise
Set rCellDevTrouvee = Workbooks(sFicherW).Sheets(FEUIL_TAUX).Range(TAB_TAUX).Columns(COL_DEV_TAUX) _
.Find(sDevise)
'Recuperer la valeur du taux
Set rCellValTaux = rCellDevTrouvee.Offset(0, COL_VAL_TAUX)
'Transmettre cette valeur de taux
Let RechercheTauxConversion = rCellValTaux.Value
End Function
'=======================================================================
' Coloriage
' Role : Procedure qui colorie la zone fournie en parametre
'
' En entree : rCellColor As Range 'zone a colorier
' iCouleur As Double 'index de la couleur
'
' En sortie : rien
'=======================================================================
Sub Coloriage(rCellColor As Range, iCouleur As Double)
With rCellColor.Interior
.ColorIndex = iCouleur 'Choix de la couleur
.Pattern = xlSolid 'Motif plein
.PatternColorIndex = xlAutomatic 'Couleur de motif
End With
End Sub
La seule chose dont j'ai besoin, c'est modifier cette ligne :
Workbooks.OpenText Filename:=Chemin_Reseau & "LGEMIREPEX.form.*" & "." & Le_ID
Le caractère * n'est pas reconnu. J'ai fais un test : la macro fonctionne si je mets les 12 caractères en dur. Il faut absolument que je puisse "sauter" ces 12 caractères pour prendre en compte tous les fichiers du répertoire.