[Catégorie modifiée .Net - VBA] Récupérer nom de fichier ftp en les listant

Question

Bonjour,

Je vous explique mon problème : j'ai une macro qui ouvre plusieurs fichiers. Seulement, l'environnement sur lequel les fichiers sont hébergés a changé, ainsi que le nommage de ces derniers. Ils sont hébergés sur un serveur Linux. Les fichiers ont cette tête :
TOTO.form.201110281445.987654321
Mon problème porte sur la première série de chiffres qui représente la date de génération du fichier. Cette dernière n'est jamais la même et je dois faire en sorte de "sauter" ces 12 caractères pour gérer plusieurs fichiers.
Dans un premier temps, j'ai essayé cette syntaxe : TOTO.form.*.987654321
Normalement, cela devrait fonctionner, mais étant donné que mes fichiers sont sur un serveur Linux, vba prend le caractère tel quel :\
La solution serait de lister les fichiers du serveur ftp. J'ai trouvé des bouts de code, mais je n'arrive pas à les faire fonctionner 

Pouvez-vous m'aider svp ?

cs_Jack · Answer

Salut

Si tu fais du VBA, ce n'est pas du .Net --> Catégorie modifiée
Merci d'en tenir compte pour tes prochaines questions.

"Pouvez-vous m'aider svp ?"
Oui, à condition de donner des infos (avant qu'on les demande).
Quel est ton code ?
"ça marche pas" n'a jamais décrit correctement les problèmes

"j'ai essayé cette syntaxe : TOTO.form.*.987654321"
Dans quelle commande ?
As-tu essayé cette autre syntaxe : TOTO.form.????????????.987654321

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)

johancc89 · Answer

Merci pour ta réponse.
Oui, désolé pour la catégorie, je me suis trompé.

Je vais essayer la syntaxe que tu me proposes dès que je peux (demain matin).
Je posterai aussi le code ;)

johancc89 · Answer

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.

[Catégorie modifiée .Net -> VBA] Récupérer nom de fichier ftp en les listant

3 réponses

Votre réponse

Discussions similaires