anthooooony
XLDnaute Occasionnel
Bonjour à tous,
je reçois chaque matin 10 fichiers par Mail un recap des actions à mener par personne. je souhaite trouver un code qui permet de récupérer seulement 4 cellules de chaque fichier. C'est un rapport que je dois faire chaque jour. En un an ça fera 10*365 = 3650 Fichiers à retraiter.
1 - j'ai un premier code qui marche(Voir ci dessous) au lancement d'une macro Outlook il envoie tout les fichiers joints excel d'un dossier(outlook) dans un dossier choisi de l'ordinateur.
2- ma deuxième étape est la où je manque d'inspiration, c'est la récupération des données en masse, j'ai renseigné le moyen de récupérer l'ensemble des 4 éléments, qui se trouvent au même endroit
Avant cela : J'ai un code aussi qui marche qui permet de recuperer en masse toutes les données de tous les fichiers d'un repertoire et de mettre les élements les uns en dessous des autres mais la mon besoin est spécifique ce n'est que certains éléments et non tout les éléments - Ce code aussi vous le trouverez pour ceux qui en aurait besoin
Les éléments à récupérer
1 - Date de l'exportation Cellule A1
"Exporté le 19/12/2012" Récupération"
=+SI(NBCAR(A1)=21;DROITE(A1;10);DROITE(A1;9)) (Pour les Jours de 1 à 9)
Donnée souhaité = 19/12/2012
2 - Nombre de dossier Cellule D7
"13 ( Périmètre = Mon périmètre de visualisation ) "
=+GAUCHE(D7;3)
Donnée souhaité = 13
3 - Nom du chargé Cellule B3
"Toto - Clients non relancés depuis 45 jours"
=GAUCHE(B3;TROUVE(" ";B3)-1)
Donnée souhaité = Toto
4 - Total (A+B) somme(k:k)/2 = 2 700 000
Récupération Finale
Jour Nb dossier Nom chargé Total en cours
19/12/2012 13 Toto 2 700 000
J'espere que vous avez compris mon besoin, n'hesitez pas à me contacter si vous avez des questions sur ma demande ou bien sur les codes que j'ai mis.
Bonne journée
RECUPERATION DES FICHIERS JOINTS RECUS SUR OUTLOOK
RÉCUPÉRATION EN MASSE DES DONNÉES DE TOUT LES FICHIERS EXCEL DANS UN DOSSIER DONNE(Attention ce code permet quelque mise en page d'un doc il faut que vous supprimiez une bonne partie du code).
je reçois chaque matin 10 fichiers par Mail un recap des actions à mener par personne. je souhaite trouver un code qui permet de récupérer seulement 4 cellules de chaque fichier. C'est un rapport que je dois faire chaque jour. En un an ça fera 10*365 = 3650 Fichiers à retraiter.
1 - j'ai un premier code qui marche(Voir ci dessous) au lancement d'une macro Outlook il envoie tout les fichiers joints excel d'un dossier(outlook) dans un dossier choisi de l'ordinateur.
2- ma deuxième étape est la où je manque d'inspiration, c'est la récupération des données en masse, j'ai renseigné le moyen de récupérer l'ensemble des 4 éléments, qui se trouvent au même endroit
Avant cela : J'ai un code aussi qui marche qui permet de recuperer en masse toutes les données de tous les fichiers d'un repertoire et de mettre les élements les uns en dessous des autres mais la mon besoin est spécifique ce n'est que certains éléments et non tout les éléments - Ce code aussi vous le trouverez pour ceux qui en aurait besoin
Les éléments à récupérer
1 - Date de l'exportation Cellule A1
"Exporté le 19/12/2012" Récupération"
=+SI(NBCAR(A1)=21;DROITE(A1;10);DROITE(A1;9)) (Pour les Jours de 1 à 9)
Donnée souhaité = 19/12/2012
2 - Nombre de dossier Cellule D7
"13 ( Périmètre = Mon périmètre de visualisation ) "
=+GAUCHE(D7;3)
Donnée souhaité = 13
3 - Nom du chargé Cellule B3
"Toto - Clients non relancés depuis 45 jours"
=GAUCHE(B3;TROUVE(" ";B3)-1)
Donnée souhaité = Toto
4 - Total (A+B) somme(k:k)/2 = 2 700 000
Récupération Finale
Jour Nb dossier Nom chargé Total en cours
19/12/2012 13 Toto 2 700 000
J'espere que vous avez compris mon besoin, n'hesitez pas à me contacter si vous avez des questions sur ma demande ou bien sur les codes que j'ai mis.
Bonne journée
RECUPERATION DES FICHIERS JOINTS RECUS SUR OUTLOOK
Code:
Sub Test()
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\**"
Outlook_Archive = "Boîte aux lettres - Anthony (FR)"
Outlook_Folder = "Boîte de réception"
Outlook_SubFolder1 = "TMA"
Outlook_SubFolder2 = ""
Outlook_SubFolder3 = ""
Subject_InStr = ""
Get_All_Files = True
Delete_Mail = False
Target_Folder = "N:\Historisation\Fichiers Tma Share\"
Target_File_Name = ""
Log_File_Long_Name = "Log Yohann"
'Shell ("C:\Documents and Settings\RC1194\Desktop\test\TEST\Test appli\TEST batch trois macros.bat")
'---------------------------------
' DO NOT CHANGE THE FOLLOWING CODE ReceivedTime &
'---------------------------------
cpt = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objFolder = objOutlook.GetNamespace("MAPI").Folders(Outlook_Archive)
On Error Resume Next
For i = 0 To 3
Select Case i
Case 0
If Not Outlook_Folder = "" Then
Set objFolder = objFolder.Folders(Outlook_Folder)
Else
Exit For
End If
Case 1
If Not Outlook_SubFolder1 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder1)
Else
Exit For
End If
Case 2
If Not Outlook_SubFolder2 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder2)
Else
Exit For
End If
Case 3
If Not Outlook_SubFolder3 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder3)
Else
Exit For
End If
End Select
Next
If Not Err.Number = 0 Then
Exit Sub
End If
On Error GoTo 0
Set objItems = objFolder.Items
For mailIndex = objItems.Count To 1 Step -1
Set objMailItem = objItems.Item(mailIndex)
If objMailItem.Attachments.Count > 0 Then
If Not InStr(1, objMailItem.Subject, Subject_InStr, 1) = 0 Then
On Error Resume Next
If Get_All_Files Then
For i = 1 To objMailItem.Attachments.Count
Set PJ = objMailItem.Attachments.Item(i)
PJ.SaveAsFile Target_Folder & PJ.DisplayName
cpt = cpt + 1
Next
Else
Set PJ = objMailItem.Attachments.Item(1)
If Target_File_Name = "" Then Target_File_Name = ReceivedTime.Value & PJ.DisplayName
PJ.SaveAsFile Target_Folder & Target_File_Name
cpt = cpt + 1
End If
If Not Err.Number = 0 Then
Exit Sub
End If
On Error GoTo 0
If Delete_Mail Then objMailItem.Delete
End If
End If
Next
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\*Copie*"
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\*image001.jpg*"
Kill "N:\Historisation\Fichiers Tma Share\*FMF*"
End SubRÉCUPÉRATION EN MASSE DES DONNÉES DE TOUT LES FICHIERS EXCEL DANS UN DOSSIER DONNE(Attention ce code permet quelque mise en page d'un doc il faut que vous supprimiez une bonne partie du code).
Code:
Private Sub Workbook_Open()
If Environ("COMPUTERNAME") = "TCSSTF275" Then
If MsgBox("Attention la macro va partir", vbYesNo) = vbYes Then
sousRépertoire = "Fichiers Tma Share"
[A2].CurrentRegion.Offset(1, 0).Clear
Set maitre = ActiveWorkbook
Repertoire = ThisWorkbook.Path
nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
n = [A1].CurrentRegion.Rows.Count - 1
[A1].CurrentRegion.Offset(1, 0).Copy _
maitre.Sheets(1).[A65000].End(xlUp).Offset(1, 0)
ActiveWorkbook.Close False
'-- nom onglet
' [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)
nf = Dir ' fichier suivant
ActiveWorkbook.RefreshAll
Loop
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
("A1:A271"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.RefreshAll 'enregistrement de tout les tcd
Range("A1").Select
Sheets("Comparatifs CSP").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
' ActiveCell.Offset(5, 0)
ActiveSheet.ChartObjects("Graphique 3").Left = ActiveCell.Offset(5, 0).Range("A1").Left
ActiveSheet.ChartObjects("Graphique 3").Top = ActiveCell.Offset(5, 0).Range("A1").Top
ActiveSheet.ChartObjects("Graphique 3").Width = Range("A:E").Width
Range("F1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveSheet.ChartObjects("Graphique 6").Left = ActiveCell.Offset(5, 0).Range("A1").Left
ActiveSheet.ChartObjects("Graphique 6").Top = ActiveCell.Offset(5, 0).Range("A1").Top
ActiveSheet.ChartObjects("Graphique 6").Width = Range("F:K").Width
Sheets("Csp Lyon").Select
Range("A1").Select
Range("A1").Select
Sheets("Csp Lyon").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
' ActiveCell.Offset(5, 0)
ActiveSheet.ChartObjects("Graphique 4").Left = ActiveCell.Offset(5, 0).Range("A1").Left
ActiveSheet.ChartObjects("Graphique 4").Top = ActiveCell.Offset(5, 0).Range("A1").Top
ActiveSheet.ChartObjects("Graphique 4").Width = Range("A:G").Width
Sheets("Csp Nanterre").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
' ActiveCell.Offset(5, 0)
ActiveSheet.ChartObjects("Graphique 2").Left = ActiveCell.Offset(5, 0).Range("A1").Left
ActiveSheet.ChartObjects("Graphique 2").Top = ActiveCell.Offset(5, 0).Range("A1").Top
ActiveSheet.ChartObjects("Graphique 2").Width = Range("A:G").Width
Sheets("Feuil2").Select
Range("A1").Select
Sheets("Feuil1").Select
Range("A1").Select
ActiveWorkbook.Save
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "anthooooony@hotmail.com"
.Subject = "Test"
' .HTMLBody = "<font face='Calibri'>Bonjour,<br><br>Veuillez trouver ci-joint les indicateurs liés aux litiges clients déclarés sur votre agence.<br><br> On appelle <b><u>Litige</u></b>, toute information en provenance de clients ou d'agences suspendant les actions de relance vers le client sur les pièces contestées. <br>" & _
"Rapport de la TMA :<br><br>" & _
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
End If
End If
End Sub
