XL 2019 Ouvrir le fichier le plus récent d'un dossier dans VBA

Cesar1275

XLDnaute Occasionnel
Bonjour à tous

Je souhaiterais créer un programme qui ouvre automatiquement le dernier fichier du répertoire C:\Users\0017475V\Documents\Solferino\Roulement .
Les fichiers sont nommés comme cela : JournalActionsRoulement_2021-02-24_10-08-43.xlsx (le 10-08-43 correspond à l'heure du fichier).

Une fois le fichier ouvert j'aimerais également pouvoir sélectionner le tableau présent dans le fichier (à partir de A9) et le copier coller dans un autre fichier ( à partir de A2).

En PJ vous trouverez les fichier (celui à ouvrir et celui ou il faut coller ( à partir de A2) le tableau sélectionné dans le premier).

N'hésitez pas à me poser des questions si ma demande n'est pas assez claire ;)
 

Pièces jointes

  • JournalActionsRoulement_2021-02-24_10-08-43.xlsx
    11 KB · Affichages: 22
  • Eléments supprimés.xlsm
    51.9 KB · Affichages: 8
Solution
Oui désolé comme je n'ai pas testé... Il manque un CurrentRegion.
Remplace :

VB:
OS.Range("A8").Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
par :
Code:
OS.Range("A8").CurrentRegion.Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination

job75

XLDnaute Barbatruc
@cesar 1275 Le chemin paraît correct s'il y a bien un dossier nommé "Données".

Par contre pour F ça ne va pas, si la feuille de destination a pour nom "Données" écrivez :
VB:
Set F = Sheets("Données")
ou si son CodeName (faites une recherche sur ce mot) est Feuil1 :
VB:
Set F = Feuil1
ou encore si la feuille de destination est la feuille active :
VB:
Set F = ActiveSheet
 

Cesar1275

XLDnaute Occasionnel
@cesar 1275 Le chemin paraît correct s'il y a bien un dossier nommé "Données".

Par contre pour F ça ne va pas, si la feuille de destination a pour nom "Données" écrivez :
VB:
Set F = Sheets("Données")
ou si son CodeName (faites une recherche sur ce mot) est Feuil1 :
VB:
Set F = Feuil1
ou encore si la feuille de destination est la feuille active :
VB:
Set F = ActiveSheet
J'ai remplacé le CodeName mais j'ai un nouveau problème.
1614343106459.png

Il me met ça dans le Sub Ouvrir...

1614343156695.png

Voici le nom de mon fichier source mais le nom change tous les jours...
 

Cesar1275

XLDnaute Occasionnel
C'est vous qui l'avez mis !!!

Ce n'est pas comme cela que j'ai défini fichier, alors débrouillez-vous !!!
Oui effectivement, j'ai adapté votre macro afin qu'elle corresponde au nom de mon nouveau fichier. J'ai constaté que vous aviez mis des "?" à la place de la date. J'ai donc fait la même chose avec le nom du nouveau fichier en pensant que cela allait fonctionner.

fichier = Dir(chemin & "JournalActionsRoulement_????-??-??_??-??-??.xlsx")

Pour preuve : voici le code que vous m'aviez fourni à l'origine.

Je déplore votre réponse fort peu cordiale alors que le ton de la discussion l'était pourtant.
 

Cesar1275

XLDnaute Occasionnel
Oui désolé comme je n'ai pas testé... Il manque un CurrentRegion.
Remplace :

VB:
OS.Range("A8").Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
par :
Code:
OS.Range("A8").CurrentRegion.Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
Re Robert

Ta macro fonctionne très bien mais il m'a été demandé d'y ajouter de nouvelles fonctions entre temps et je n'ai malheureusement pas réussi à les faires tout seul.

1 - Il faudrait faire en sorte que la macro ne compte pas non plus les lignes avec des numéros de train commençant par 149 et 19.
Ex :
Suppression d'un élément avec graphicageLCLADE944411/02/2021 14:22HOUITTE SandrineSuppression avec graphicage de l'élément de rang 2/2 de l'étape 197444 du jeudi 11/02/2021.

2 - Il faudrait également que la macro compare les lignes avec un autre tableau présent sur la feuille "restauration" du tableur afin de supprimer (dans la feuille 1) celles qui sont en doublon.

Je sais que ma demande n'est pas facile donc si tu as des questions n'hésite pas !

Merci d'avance !
 

Pièces jointes

  • Eléments supprimés.xlsm
    97.6 KB · Affichages: 6

job75

XLDnaute Barbatruc
1 - Il faudrait faire en sorte que la macro ne compte pas non plus les lignes avec des numéros de train commençant par 149 et 19.
A tester :
VB:
Sub Importer()
Dim F As Worksheet
Set F = Sheets("Données") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        .Columns(6).Replace "*train 19*", "#N/A", xlWhole
        .Columns(6).Replace "*étape 19*", "#N/A"
        .Columns(6).Replace "*train 149*", "#N/A"
        .Columns(6).Replace "*étape 149*", "#N/A"
        On Error Resume Next 'si aucune SpecialCell
        .Columns(6).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\ICV - HRE\Données\" 'à adapter
fichier = Dir(chemin & "Suivi_Qualité_ICV_??????_lignes.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
 

Cesar1275

XLDnaute Occasionnel
A tester :
VB:
Sub Importer()
Dim F As Worksheet
Set F = Sheets("Données") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        .Columns(6).Replace "*train 19*", "#N/A", xlWhole
        .Columns(6).Replace "*étape 19*", "#N/A"
        .Columns(6).Replace "*train 149*", "#N/A"
        .Columns(6).Replace "*étape 149*", "#N/A"
        On Error Resume Next 'si aucune SpecialCell
        .Columns(6).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\ICV - HRE\Données\" 'à adapter
fichier = Dir(chemin & "Suivi_Qualité_ICV_??????_lignes.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
Bonjour Job 75

Merci pour ta réponse !

Ta macro fonctionne surement, le problème est qu'elle ne reprends pas les fonctions qui existaient déjà dans la macro de Robert. En tout cas je n'ai pas réussi à l'intégrer correctement.
 

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

J'ai modifié le code ainsi pour les trains. Est-ce que ça convient ?

VB:
Sub test()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim EF As Object 'déclare la variable EF (Explorateur de Fichiers)
Dim DS As Object 'déclare la variable DS (Dossier Source)
Dim FS As Object 'déclare la variable FS (FichierS)
Dim F As Object 'déclare la variable F (Fichier)
Dim FN As String 'déclare la variable FN (Fin du Nom)
Dim DSer As Date 'déclare la variable DSer (Date Serial)
Dim HSer As Variant 'déclare la variable HSer (Heure Serial)
Dim DeH As Variant 'déclare la variable DeH (Date et Heure)
Dim Max As Variant 'déclare la variable Max (valeur MAXimale)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim NT As String 'déclare la variable NT (Numéro de Train)

Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
CA = "Z:\poubelle\Cesar"
'CA = "C:\Users\0017475V\Documents\Solferino\Roulement\Journal Actions" 'définit le chemin d'acces CA
Set EF = CreateObject("Scripting.FileSystemObject") 'définit l'explorateur de fichiers EF
Set DS = EF.GetFolder(CA) 'définit le dossier source DS
Set FS = DS.Files 'définit l'ensemble des fichier FS du dossier source DS
For Each F In FS 'boucle sur tous les fichiers F de FS
    If Left(F.Name, 23) = "JournalActionsRoulement" Then 'condition : si le nom du fichier commence par "JournalActionsRoulement"
        FN = Split(Mid(F.Name, 25), ".")(0) 'définit la fin du nom FN (date et heure)
        DSer = DateSerial(Year(Split(FN, "_")(0)), Month(Split(FN, "_")(0)), Day(Split(FN, "_")(0))) 'définit le numero de série de la date DSer
        HSer = TimeSerial(Split(Split(FN, "_")(1), "-")(0), Split(Split(FN, "_")(1), "-")(1), Split(Split(FN, "_")(1), "-")(2)) 'définit le numéro de série de l'heure HSer
        DeH = DSer & " " & HSer 'définit la date et l'heure DeH
        If DeH > Max Then Max = DeH: NF = F.Name 'si Deh est supérieure à Max (qui au départ vaut 0), définit la variable Max et le nom du fichier NF
    End If 'fin de la condition
Next F 'prochain fichier de la boucle
Set CS = Workbooks.Open(CA & "\" & NF) 'définit la classeur source CS (ayant NF comme nom) en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
OS.Range("A8:F2000").Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
CS.Close False 'ferme le classeur source sans enregistrer les modifications
OD.Range("AN1:AO2").Copy
DL = OD.Cells(Application.Rows.Count, "F").End(xlUp).Row
OD.Range("A2:F" & DL).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    
Set dico = CreateObject("scripting.dictionary")
Set dates = CreateObject("scripting.dictionary")
For n = 2 To DL
    
    '***************
    'numéro de train
    If UBound(Split(OD.Cells(n, "F").Value, " ")) > 9 Then
        NT = Split(OD.Cells(n, "F").Value, " ")(10)
        If Left(NT, 2) = 19 Or lef(NT, 3) = 149 Then GoTo suite
    End If
    '***************
    
    If InStr(Range("F" & n), "Suppression avec graphicage de l'élément de rang") <> 0 Then
        x = Range("F" & n)
        dico(x) = Right(x, 11)
        dates(Right(x, 11)) = CDate(Replace(Right(x, 11), ".", ""))
    End If
suite: 'étiquette
Next n
A = dico.keys
b = dico.items
C = dates.keys
For n = LBound(C) To UBound(C)
    For m = LBound(C) To UBound(C)
        If C(n) < C(m) Then temp = C(n): C(n) = C(m): C(m) = temp
    Next m
Next n
Range("H2:I32").ClearContents
For n = LBound(C) To UBound(C)
    Cells(2 + n, 8) = C(n)
    For m = LBound(A) To UBound(A)
        If b(m) = C(n) Then tot = tot + 1
    Next
    Cells(2 + n, 9) = tot
    tot = 0
Next
End Sub

Pour ce qui est des doublons par rapport au second tableau, qu'est-ce qui caractérise un doublons , colonnes A à E strictement identiques ?
 

job75

XLDnaute Barbatruc
Avec ce fichier (2) on traite aussi les doublons de lignes identiques avec la feuille "Restauration" :
VB:
Sub Importer()
Dim d As Object, tablo, i&, F As Worksheet, x$
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("Restauration").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & tablo(i, 6)) = ""
Next
'---traitement et copie du fichier source---
Set F = Sheets("Données") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        tablo = .Value 'matrice, plus rapide
        For i = UBound(tablo) To 2 Step -1
            x = tablo(i, 6)
            If InStr(x, "train 19") Or InStr(x, "étape 19") Or InStr(x, "train 149") Or InStr(x, "étape 149") _
                Or d.exists(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & x) Then .Rows(i).Delete xlUp
        Next
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\ICV - HRE\Données\" 'à adapter
'chemin = ThisWorkbook.Path & "\" 'pour tester plus facilement chez moi...
fichier = Dir(chemin & "Suivi_Qualité_ICV_??????_lignes.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
Les lignes sont supprimées une par une, s'il y en avait beaucoup il faudrait procéder autrement.
 

Pièces jointes

  • Eléments supprimés(2).xlsm
    85.6 KB · Affichages: 2
  • Suivi_Qualité_ICV_210301_lignes.xlsx
    11 KB · Affichages: 2
Dernière édition:

Cesar1275

XLDnaute Occasionnel
Bonjour le fil, bonjour le forum,

J'ai modifié le code ainsi pour les trains. Est-ce que ça convient ?

VB:
Sub test()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim EF As Object 'déclare la variable EF (Explorateur de Fichiers)
Dim DS As Object 'déclare la variable DS (Dossier Source)
Dim FS As Object 'déclare la variable FS (FichierS)
Dim F As Object 'déclare la variable F (Fichier)
Dim FN As String 'déclare la variable FN (Fin du Nom)
Dim DSer As Date 'déclare la variable DSer (Date Serial)
Dim HSer As Variant 'déclare la variable HSer (Heure Serial)
Dim DeH As Variant 'déclare la variable DeH (Date et Heure)
Dim Max As Variant 'déclare la variable Max (valeur MAXimale)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim NT As String 'déclare la variable NT (Numéro de Train)

Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
CA = "Z:\poubelle\Cesar"
'CA = "C:\Users\0017475V\Documents\Solferino\Roulement\Journal Actions" 'définit le chemin d'acces CA
Set EF = CreateObject("Scripting.FileSystemObject") 'définit l'explorateur de fichiers EF
Set DS = EF.GetFolder(CA) 'définit le dossier source DS
Set FS = DS.Files 'définit l'ensemble des fichier FS du dossier source DS
For Each F In FS 'boucle sur tous les fichiers F de FS
    If Left(F.Name, 23) = "JournalActionsRoulement" Then 'condition : si le nom du fichier commence par "JournalActionsRoulement"
        FN = Split(Mid(F.Name, 25), ".")(0) 'définit la fin du nom FN (date et heure)
        DSer = DateSerial(Year(Split(FN, "_")(0)), Month(Split(FN, "_")(0)), Day(Split(FN, "_")(0))) 'définit le numero de série de la date DSer
        HSer = TimeSerial(Split(Split(FN, "_")(1), "-")(0), Split(Split(FN, "_")(1), "-")(1), Split(Split(FN, "_")(1), "-")(2)) 'définit le numéro de série de l'heure HSer
        DeH = DSer & " " & HSer 'définit la date et l'heure DeH
        If DeH > Max Then Max = DeH: NF = F.Name 'si Deh est supérieure à Max (qui au départ vaut 0), définit la variable Max et le nom du fichier NF
    End If 'fin de la condition
Next F 'prochain fichier de la boucle
Set CS = Workbooks.Open(CA & "\" & NF) 'définit la classeur source CS (ayant NF comme nom) en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
OS.Range("A8:F2000").Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
CS.Close False 'ferme le classeur source sans enregistrer les modifications
OD.Range("AN1:AO2").Copy
DL = OD.Cells(Application.Rows.Count, "F").End(xlUp).Row
OD.Range("A2:F" & DL).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
   
Set dico = CreateObject("scripting.dictionary")
Set dates = CreateObject("scripting.dictionary")
For n = 2 To DL
   
    '***************
    'numéro de train
    If UBound(Split(OD.Cells(n, "F").Value, " ")) > 9 Then
        NT = Split(OD.Cells(n, "F").Value, " ")(10)
        If Left(NT, 2) = 19 Or lef(NT, 3) = 149 Then GoTo suite
    End If
    '***************
   
    If InStr(Range("F" & n), "Suppression avec graphicage de l'élément de rang") <> 0 Then
        x = Range("F" & n)
        dico(x) = Right(x, 11)
        dates(Right(x, 11)) = CDate(Replace(Right(x, 11), ".", ""))
    End If
suite: 'étiquette
Next n
A = dico.keys
b = dico.items
C = dates.keys
For n = LBound(C) To UBound(C)
    For m = LBound(C) To UBound(C)
        If C(n) < C(m) Then temp = C(n): C(n) = C(m): C(m) = temp
    Next m
Next n
Range("H2:I32").ClearContents
For n = LBound(C) To UBound(C)
    Cells(2 + n, 8) = C(n)
    For m = LBound(A) To UBound(A)
        If b(m) = C(n) Then tot = tot + 1
    Next
    Cells(2 + n, 9) = tot
    tot = 0
Next
End Sub

Pour ce qui est des doublons par rapport au second tableau, qu'est-ce qui caractérise un doublons , colonnes A à E strictement identiques ?
Merci pour ta réponse !

Effectivement je n'avais pas donné assez de précisions.

En fait les doublons sont caractérisés par des numéros de trains identiques dans les colonnes F des 2 tableaux (Eléments supprimés et JournalActionsRoulement). Comme tu peux le constater le contenu des cellules ne sont pas identiques, c'est pour cela qu'il faut comparer uniquement les numéro de train et supprimer les doublons dans le tableau Eléments supprimés.

Le plus simple serait que tu reprenne le code que tu m'a donné la dernière fois (qui marche parfaitement) et que tu y ajoute une fonction qui copie les données du tableau JournalActionsRoulement (de A8 à F2000) et qui les colle dans le feuille "restauration" du tableau Eléments supprimés. Après cela il faudra comparer les deux feuilles pour trouver les doublons et supprimer ceux présents dans la feuille "Feuil1".

Adresse JournalActionsRoulement : C:\Users\0017475V\Documents\Solferino\Roulement\Restaurations

Voici la macro que tu m'avais donné et qui fonctionne très bien :

VB:
Sub test()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim EF As Object 'déclare la variable EF (Explorateur de Fichiers)
Dim DS As Object 'déclare la variable DS (Dossier Source)
Dim FS As Object 'déclare la variable FS (FichierS)
Dim F As Object 'déclare la variable F (Fichier)
Dim FN As String 'déclare la variable FN (Fin du Nom)
Dim DSer As Date 'déclare la variable DSer (Date Serial)
Dim HSer As Variant 'déclare la variable HSer (Heure Serial)
Dim DeH As Variant 'déclare la variable DeH (Date et Heure)
Dim Max As Variant 'déclare la variable Max (valeur MAXimale)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)

Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
CA = "C:\Users\0017475V\Documents\Solferino\Roulement\Journal Actions" 'définit le chemin d'acces CA
Set EF = CreateObject("Scripting.FileSystemObject") 'définit l'explorateur de fichiers EF
Set DS = EF.GetFolder(CA) 'définit le dossier source DS
Set FS = DS.Files 'définit l'ensemble des fichier FS du dossier source DS
For Each F In FS 'boucle sur tous les fichiers F de FS
    If Left(F.Name, 23) = "JournalActionsRoulement" Then 'condition : si le nom du fichier commence par "JournalActionsRoulement"
        FN = Split(Mid(F.Name, 25), ".")(0) 'définit la fin du nom FN (date et heure)
        DSer = DateSerial(Year(Split(FN, "_")(0)), Month(Split(FN, "_")(0)), Day(Split(FN, "_")(0))) 'définit le numero de série de la date DSer
        HSer = TimeSerial(Split(Split(FN, "_")(1), "-")(0), Split(Split(FN, "_")(1), "-")(1), Split(Split(FN, "_")(1), "-")(2)) 'définit le numéro de série de l'heure HSer
        DeH = DSer & " " & HSer 'définit la date et l'heure DeH
        If DeH > Max Then Max = DeH: NF = F.Name 'si Deh est supérieure à Max (qui au départ vaut 0), définit la variable Max et le nom du fichier NF
    End If 'fin de la condition
Next F 'prochain fichier de la boucle
Set CS = Workbooks.Open(CA & "\" & NF) 'définit la classeur source CS (ayant NF comme nom) en l'ouvrant
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
OS.Range("A8:F2000").Offset(1, 0).Copy OD.Range("A2") 'copy le tableau de l'onglet source à partir de A9 et le colle dans A2 de l'onglet destination
CS.Close False 'ferme le classeur source sans enregistrer les modifications

 Range("AN1:AO2").Select
    Selection.Copy
    Range("A2", Range("F" & Rows.Count).End(xlUp)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
Set dico = CreateObject("scripting.dictionary")
Set dates = CreateObject("scripting.dictionary")
For n = 2 To Range("F" & Rows.Count).End(xlUp).Row
If InStr(Range("F" & n), "Suppression avec graphicage de l'élément de rang") <> 0 Then
   x = Range("F" & n)
  dico(x) = Right(x, 11)
  dates(Right(x, 11)) = CDate(Replace(Right(x, 11), ".", ""))
End If
Next
A = dico.keys
b = dico.items
C = dates.keys
For n = LBound(C) To UBound(C)
  For m = LBound(C) To UBound(C)
     If C(n) < C(m) Then
        temp = C(n)
        C(n) = C(m)
        C(m) = temp
     End If
  Next
Next
Range("H2:H32").ClearContents
Range("I2:I32").ClearContents
For n = LBound(C) To UBound(C)
   Cells(2 + n, 8) = C(n)
     For m = LBound(A) To UBound(A)
        If b(m) = C(n) Then tot = tot + 1
    Next
    Cells(2 + n, 9) = tot
    tot = 0
Next

End Sub
 

Cesar1275

XLDnaute Occasionnel
Avec ce fichier (2) on traite aussi les doublons de lignes identiques avec la feuille "Restauration" :
VB:
Sub Importer()
Dim d As Object, tablo, i&, F As Worksheet, x$
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("Restauration").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & tablo(i, 6)) = ""
Next
'---traitement et copie du fichier source---
Set F = Sheets("Données") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        tablo = .Value 'matrice, plus rapide
        For i = UBound(tablo) To 2 Step -1
            x = tablo(i, 6)
            If InStr(x, "train 19") Or InStr(x, "étape 19") Or InStr(x, "train 149") Or InStr(x, "étape 149") _
                Or d.exists(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & x) Then .Rows(i).Delete xlUp
        Next
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\ICV - HRE\Données\" 'à adapter
'chemin = ThisWorkbook.Path & "\" 'pour tester plus facilement chez moi...
fichier = Dir(chemin & "Suivi_Qualité_ICV_??????_lignes.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
Les lignes sont supprimées une par une, s'il y en avait beaucoup il faudrait procéder autrement.
Merci Job75 !

Ta macro fonctionne et colle bien les données dans la feuille "restauration" comme je le voulais !
Le seul petit problème est qu'elle oubli de copier le première ligne du tableau. Il y en a normalement 7 alors qu'elle n'est colle que 6 ...

Je te remet ton code avec les chemins et les noms de feuilles que j'ai modifié.

Code:
Sub Importer()
Dim d As Object, tablo, i&, F As Worksheet, x$
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("Restauration").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & tablo(i, 6)) = ""
Next
'---traitement et copie du fichier source---
Set F = Sheets("restauration") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        tablo = .Value 'matrice, plus rapide
        For i = UBound(tablo) To 2 Step -1
            x = tablo(i, 6)
            If InStr(x, "train 19") Or InStr(x, "étape 19") Or InStr(x, "train 149") Or InStr(x, "étape 149") _
                Or d.exists(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & x) Then .Rows(i).Delete xlUp
        Next
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\Solferino\Roulement\Restaurations\" 'à adapter
'chemin = ThisWorkbook.Path & "\" 'pour tester plus facilement chez moi...
fichier = Dir(chemin & "JournalActionsRoulement.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
[QUOTE="Cesar1275, post: 20409360, member: 315701"]

[/QUOTE]
 

Cesar1275

XLDnaute Occasionnel
Avec ce fichier (2) on traite aussi les doublons de lignes identiques avec la feuille "Restauration" :
VB:
Sub Importer()
Dim d As Object, tablo, i&, F As Worksheet, x$
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("Restauration").[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & tablo(i, 6)) = ""
Next
'---traitement et copie du fichier source---
Set F = Sheets("Données") 'à adapter
Application.ScreenUpdating = False
F.Range("A2:F" & F.Rows.Count).ClearContents 'RAZ
Ouvrir 'lance la macro
With ActiveWorkbook
    If .Name = ThisWorkbook.Name Then Exit Sub
    With .Sheets(1).[A8].CurrentRegion.Resize(, 6)
        tablo = .Value 'matrice, plus rapide
        For i = UBound(tablo) To 2 Step -1
            x = tablo(i, 6)
            If InStr(x, "train 19") Or InStr(x, "étape 19") Or InStr(x, "train 149") Or InStr(x, "étape 149") _
                Or d.exists(tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & Format(tablo(i, 4), "dd/mm/yyyy hh:mm:ss") & tablo(i, 5) & x) Then .Rows(i).Delete xlUp
        Next
        If .Rows.Count > 1 Then _
            F.[A2].Resize(.Rows.Count - 1, 6) = .Offset(1).Resize(.Rows.Count - 1).Value 'copie les valeurs
    End With
    .Close False 'ferme le fichier
End With
End Sub

Sub Ouvrir()
Dim chemin$, fichier$, x$
chemin = "C:\Users\0017475V\Documents\ICV - HRE\Données\" 'à adapter
'chemin = ThisWorkbook.Path & "\" 'pour tester plus facilement chez moi...
fichier = Dir(chemin & "Suivi_Qualité_ICV_??????_lignes.xlsx")
While fichier <> "": x = fichier: fichier = Dir: Wend
If x <> "" Then Workbooks.Open chemin & x Else MsgBox "Aucun fichier trouvé..."
End Sub
Les lignes sont supprimées une par une, s'il y en avait beaucoup il faudrait procéder autrement.
Re Job 75

Je me suis mal exprimé. En fait je voudrais que la macro supprime les lignes avec les numéros de train 149 et 19 mais dans la feuille de données "Feuil1". Ta macro le fait à condition de renseigner les bons chemins mais elle ne permet pas de compter le nombre de lignes comprenant "Suppression avec graphicage de l'élément de rang" comme le fait celle de Robert.
 

Discussions similaires

Statistiques des forums

Discussions
312 083
Messages
2 085 183
Membres
102 808
dernier inscrit
guo