importer les dernieres lignes de fichiers fermé

[auverland]

Bonjour,

J'espère que tout le monde à passé de bonne vacances.. J'aurai besoin d'un petit coup de pousse

J'ai différents fichiers sous forme de journal. Date + différentes informations
je souhaiterais faire une macro qui me recopie les lignes non vide de chaque fichier "cahier_classeur" a partir de la dernière date et qu'il me les colles les unes à la suite des autres dans le fichier "mise à jour cahier".
Vu qu'il y aurait presque le même information j'aimerais qu'il m'indique en colonne A le nom du fichier qui correspond.

J'ai commencer à écrire la macro pour aller chercher les fichiers mais pour la recopie et le collage des données je sèche littéralement.

Deuxième aide vraiment facultative
J'ai trouver une macro pour pour diffuser par mail le résultat. est-il possible de récupérer la liste de diffusion en feuille deux ? j'ai intégrer les adresses dans la macro et sa fonctionne mais ce serai plus pratique.

Merci pour votre aide et bonne fin de semaine

deux cahier + le mise à jour cahier que j'aimerai remplir automatiquement

 

[Staple1600]

Re : importer les dernieres lignes de fichiers fermé

Bonsoir à tous


Voici une première suggestion (à peaufiner)
(test OK avec tes fichiers joints, à condition qu'ils contiennent en colonne A la date du jour courant)

Sub PremierEssai()
Dim fd As Office.FileDialog, SRC_WBK As Workbook
Dim DerDate As Range, Dest_Rng As Range, DerLig&
Set Dest_Rng = ThisWorkbook.Sheets("Point J").Cells(Rows.Count, "A").End(xlUp)
Dest_Rng.Offset(, 1).Resize(136, 5) = Empty
'choix du fichier
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
      .AllowMultiSelect = False
      .Title = "Veuillez sélectionner un classeur."
      .Filters.Clear
      .Filters.Add "Excel 2007-2013", "*.xlsx"
      .Filters.Add "Tous fichiers", "*.*"
      If .Show = True Then
      Set SRC_WBK = Workbooks.Open(.SelectedItems(1))
      End If
End With
Application.ScreenUpdating = False
With SRC_WBK.Sheets(1)
'détermination de la dernière ligne non vide
DerLig = .Cells.Find("*", SearchOrder:=1, SearchDirection:=2).Row
'recherche de la date du jour
Set DerDate = .Columns("A:A").Find(What:=Date, After:=.Cells(1, 1), LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
'recopie des données
.Range(.Cells(DerDate.Row, "A"), .Cells(DerLig, "E")).Copy Dest_Rng.Offset(, 1)
End With
Dest_Rng = Split(SRC_WBK.Name, ".")(0)
SRC_WBK.Close False
Dest_Rng.Select
Application.ScreenUpdating = True
End Sub

 

[auverland]

Re : importer les dernieres lignes de fichiers fermé

Bonjour,

Merci pour ces premiers éléments

je souhaiterais qu'il boucle sur tout les sous-répertoires et colle les réponses les une sous les autres

J'ai adapter ceci mais il ouvre pas les fichiers :

Sub Import()
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String
Dim Colonne As Integer

Dim fd As Office.FileDialog, SRC_WBK As Workbook 'ajout
Dim DerDate As Range, Dest_Rng As Range, DerLig& ' ajout
Set Dest_Rng = ThisWorkbook.Sheets("Point J").Cells(Rows.Count, "A").End(xlUp)
Dest_Rng.Offset(, 1).Resize(136, 5) = Empty ' ajout vidage tableau

'ouverture de la fenêtre de choix du répertoire
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
'Si l'utilisateur annule sans choisir
If objFolder Is Nothing Then
'message
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else 'sinon
'Chemin = répertoire choisi
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
'Choix du 1er fichier
fichier = Dir(Chemin & "Cahier*.xls*")

'on boucle sur tous les fichiers excel du répertoire choisi
' Application.ScreenUpdating = False
End If
Do While Len(fichier) > 0
If fichier <> ThisWorkbook.Name Then

Set SRC_WBK = ThisWorkbook


With SRC_WBK.Sheets(1)
'détermination de la dernière ligne non vide
DerLig = .Cells.Find("*", SearchOrder:=1, SearchDirection:=2).Row
'recherche de la date du jour
Set DerDate = .Columns("A:A").Find(What:=Date, After:=.Cells(1, 1), LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'recopie des données
.Range(.Cells(DerDate.Row, "A"), .Cells(DerLig, "E")).Copy Dest_Rng.Offset(, 1)
End With
Dest_Rng = Split(SRC_WBK.Name, ".")(0)
SRC_WBK.Close False
Dest_Rng.Select


End If

fichier = Dir()
Loop
'Application.ScreenUpdating = tree
End Sub

Merci si vous avez une idée et bonne semaine