XL 2019 Modifier un fichier Excel

[ChristianJ]

Bonjour à tous ,

Je souhaite apporter plusieurs modification à plusieurs fichier excel qui sont dans un dossier avec une macro. J'ai déja une macro mais elle ne modifie que le premier fichier de mon dossier et en plus elle prend beaucoup de temps

J'ai 136 fichiers que je souhaite modifier comme suit :

1 - Ajouter une colonne après la première colonne

2 - Convertir la première colonne avec un séparateur espace ( j'aurais deux une colonne date et une autre heure, respectivement sur la colonne A et B )

3- Modifier le format de de la colonne A en "Date courte" et la colonne B en "heure"

4- le faire pour chaque fichier qui se trouve dans un dossier "Fichier FR"

En pièce jointe un fichier fait à la main "fr0524" et la forme des autres fichiers "fr0248" et le fichier contenant le programme VBA "christainJ-tarnsformation"

J’espère vraiment que vous pourrez m'aidez

 

[ChTi160]

Bonjour Christian
Bonjour le Fil ,le Forum
pas évident de comprendre Lol

1 - Ajouter une colonne après la première colonne
2 - Convertir la première colonne avec un séparateur espace ( j'aurais deux une colonne date et une autre heure, respectivement sur la colonne A et B )
3- Modifier le format de de la colonne A en "Date courte" et la colonne B en "heure"
4- le faire pour chaque fichier qui se trouve dans un dossier "Fichier FR"

tu aurais du mettre un Fichier avant transformation et un autre avec ce que tu veux après transformation (avec explications Lol).
j'ai vu que dans la macro tu vas chercher une date en A2 ?? ,et même l'heure en A2 ????
Merci par avance
jean marie

 

[ChristianJ]

Bonjour Christian
Bonjour le Fil ,le Forum
pas évident de comprendre Lol

tu aurais du mettre un Fichier avant transformation et un autre avec ce que tu veux après transformation (avec explications Lol).
j'ai vu que dans la macro tu vas chercher une date en A2 ?? ,et même l'heure en A2 ????
Merci par avance
jean marie

Bonjour Jean marie,

merci de ta réponse. le fichier avant transformation est le FR0248 et celui après transformation est le fr0524.

En gros , j'ai un dossier avec des fichiers excel renommé FRXXXX, je veux dans ces fichiers convertir la première colonne qui contient les infos de date et heure en une colonne date et une colonne heure indépendante. Et le faire pour tous les fichiers FRXXXX qui sont dans mon dossier.

A vrai dire je ne saurais t'expliquer la macro dans les détails ( ce n'est pas moi qui l'ai écrit), je ne comprends pas beaucoup, si ce n'est les commentaires. Mais je sais que ça ne modifie qui un fichier de tous les fichiers de mon dossier.


Merci par avance

 

[ChTi160]

Re
Ok merci
Jean marie

 

[danielco]

Bonjour,

Modifie la ligne Chemin = ... en indiquant le chemin des fichiers, et essaie :

Sub test()
  Dim Chemin As String, Fich As String, Ligne As Long, Tabl1 As Variant, Tabl2() As Double
  Dim Wbk As Workbook, I As Long
  Chemin = "D:\Users\dcola\Documents\Donnees\Daniel\mpfe\ChristianJ\Fichier FR"
  Application.ScreenUpdating = False
  Fich = Dir(Chemin & "\*.xlsx")
  Do While Fich <> ""
    Set Wbk = Workbooks.Open(Chemin & "\" & Fich)
    With Wbk.Sheets(1)
      Tabl1 = Application.Transpose(.Range("A2", .Cells(.Rows.Count, 1).End(xlUp)))
      Ligne = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Rows.Count
      ReDim Tabl2(Ligne, 1)
      For I = 1 To UBound(Tabl1)
        Tabl2(I - 1, 0) = Int(Tabl1(I))
        Tabl2(I - 1, 1) = Tabl1(I) - Int(Tabl1(I))
      Next I
      .Columns(2).Insert
      .[A2].Resize(Ligne, 2) = Tabl2
      .Columns("A:A").NumberFormat = "m/d/yyyy"
      .Columns("B:B").NumberFormat = "hh:mm:ss"
      .Range("A1") = "Date"
      .Range("B1") = "Heure"
    End With
    Wbk.Close True
  Loop
  Application.ScreenUpdating = True
End Sub

Daniel

 

[ChTi160]

Re
Bonjour danielco
procédures qui semble faire l'affaire Lol

Option Explicit
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim DerLgn As Long
Dim Dossier As String
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim DS As Object 'déclare la variable DS (Dossier Source)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)

Sub TestListeFichiers() 'Procédure de lancement de la recherche
    'Définit le répertoire Source ou l'on va rechercher les fichiers.
     Dossier = ThisWorkbook.Path 'Chemin d'accès
   
    'Appelle la procédure de recherche des fichiers
    ModifierFichiers Dossier
   
    MsgBox "Terminé"
End Sub

Sub ModifierFichiers(Repertoire As String) 
        'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
Application.ScreenUpdating = False 'inhibe l’écran
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
       If FileItem.Name Like "fr####.xlsx" Then
         F = FileItem.Name
'définit le classeur source CS en l'ouvrant
    Set CS = Workbooks.Open(Dossier & "\" & F)
With CS 'Avec le Classeur
With .Worksheets(1) 'Avec la feuille 1 de ce classeur
   If .Cells(1, 1) = "Date Heure" Then 'On vérifie si déjà traitée  
'On Récupère le numéro de la dernière ligne non vide dans la colonne A.
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row
         .Columns("B:C").Insert Shift:=xlToRight 'On insére deux Colonnes
        ' Date en colonne B
         .Range("B1").Value = "Date" 'On met
    With .Range("B2:B" & DerLgn)
         .FormulaLocal = "=DATE(ANNEE(A2);MOIS(A2);JOUR(A2))"
         .Value = .Value
         .NumberFormat = "dd/mm/yyyy"
    End With
    ' Heure en colonne C
         .Range("C1").Value = "Heure" 'On met
    With .Range("C2:C" & DerLgn)
         .FormulaLocal = "=TEMPS(HEURE(A2);MINUTE(A2);SECONDE(A2))"
         .Value = .Value
         .NumberFormat = "hh:mm:ss"
    End With
    ' Supprimer la colonne A
         .Columns("A:A").Delete Shift:=xlToLeft
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
         .Columns("A:D").AutoFit
   End If
End With
End With
     CS.Close True 'ferme le classeur source CS en l'enregistrer
        End If
    Next FileItem
    Set CS = Nothing: Set FileItem = Nothing
         F = Empty
Application.ScreenUpdating = True
End Sub

Bonne fin de journée
jean marie
PS : daniel ! que ce passe t'il si on lance plusieurs fois ta Procédure ?

 

[danielco]

Re
Bonjour danielco
procédures qui semble faire l'affaire Lol

Option Explicit
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim DerLgn As Long
Dim Dossier As String
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim DS As Object 'déclare la variable DS (Dossier Source)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)

Sub TestListeFichiers() 'Procédure de lancement de la recherche
    'Définit le répertoire Source ou l'on va rechercher les fichiers.
     Dossier = ThisWorkbook.Path 'Chemin d'accès
  
    'Appelle la procédure de recherche des fichiers
    ModifierFichiers Dossier
  
    MsgBox "Terminé"
End Sub

Sub ModifierFichiers(Repertoire As String)
        'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
Application.ScreenUpdating = False 'inhibe l’écran
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
       If FileItem.Name Like "fr####.xlsx" Then
         F = FileItem.Name
'définit le classeur source CS en l'ouvrant
    Set CS = Workbooks.Open(Dossier & "\" & F)
With CS 'Avec le Classeur
With .Worksheets(1) 'Avec la feuille 1 de ce classeur
   If .Cells(1, 1) = "Date Heure" Then 'On vérifie si déjà traitée 
'On Récupère le numéro de la dernière ligne non vide dans la colonne A.
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row
         .Columns("B:C").Insert Shift:=xlToRight 'On insére deux Colonnes
        ' Date en colonne B
         .Range("B1").Value = "Date" 'On met
    With .Range("B2:B" & DerLgn)
         .FormulaLocal = "=DATE(ANNEE(A2);MOIS(A2);JOUR(A2))"
         .Value = .Value
         .NumberFormat = "dd/mm/yyyy"
    End With
    ' Heure en colonne C
         .Range("C1").Value = "Heure" 'On met
    With .Range("C2:C" & DerLgn)
         .FormulaLocal = "=TEMPS(HEURE(A2);MINUTE(A2);SECONDE(A2))"
         .Value = .Value
         .NumberFormat = "hh:mm:ss"
    End With
    ' Supprimer la colonne A
         .Columns("A:A").Delete Shift:=xlToLeft
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
         .Columns("A:D").AutoFit
   End If
End With
End With
     CS.Close True 'ferme le classeur source CS en l'enregistrer
        End If
    Next FileItem
    Set CS = Nothing: Set FileItem = Nothing
         F = Empty
Application.ScreenUpdating = True
End Sub

Bonne fin de journée
jean marie
PS : daniel ! que ce passe t'il si on lance plusieurs fois ta Procédure ?

Bonjour @ChTi160 ,

Euh, je ne sais pas, elle va traiter les fichiers plusieurs fois ? Je n'ai pas le temps de lire ton code. Qu'est-ce qui cloche dans le mien ?

Daniel

 

[ChTi160]

Re
Eh bien je pense qu'a chaque fois la procédure va agir sur les fichiers "fr*.xlsx" alors qu'il n'y aura plus de données a traiter x fois.
Je pense non testé lol
C'est pourquoi j'ai mis un test sur la cellule A1
On effectue la procédure si A1 = "Date Heure"
Mais bon !
Bonne soirée
Jean marie

 

[danielco]

Effectivement. Ma moulinette a été faite pour être exécutée une fois. Après, on la jette. C'est basique, mais c'est ce qui était demandé, non ?

Daniel

 

[ChTi160]

Re
Oui peut être ! mais pas explicite Lol !
jean marie

 

[ChristianJ]

Merci à tous pour vos réponses,
j'ai trouvé la solution à mon problème. je vais quand même essayer vos solutions. en photo et surligné en jaune la ligne qu'il manquait.

merci vraiment à tous vous êtes top

 

[danielco]

D'ailleurs, comme tu le signales, cette ligne manque aussi dans mon code, honte à moi :

Sub test()
  Dim Chemin As String, Fich As String, Ligne As Long, Tabl1 As Variant, Tabl2() As Double
  Dim Wbk As Workbook, I As Long
  Chemin = "D:\Users\dcola\Documents\Donnees\Daniel\mpfe\ChristianJ\Fichier FR"
  Application.ScreenUpdating = False
  Fich = Dir(Chemin & "\*.xlsx")
  Do While Fich <> ""
    Set Wbk = Workbooks.Open(Chemin & "\" & Fich)
    With Wbk.Sheets(1)
      Tabl1 = Application.Transpose(.Range("A2", .Cells(.Rows.Count, 1).End(xlUp)))
      Ligne = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Rows.Count
      ReDim Tabl2(Ligne, 1)
      For I = 1 To UBound(Tabl1)
        Tabl2(I - 1, 0) = Int(Tabl1(I))
        Tabl2(I - 1, 1) = Tabl1(I) - Int(Tabl1(I))
      Next I
      .Columns(2).Insert
      .[A2].Resize(Ligne, 2) = Tabl2
      .Columns("A:A").NumberFormat = "m/d/yyyy"
      .Columns("B:B").NumberFormat = "hh:mm:ss"
      .Range("A1") = "Date"
      .Range("B1") = "Heure"
    End With
    Wbk.Close True
    Fich = Dir
  Loop
  Application.ScreenUpdating = True
End Sub

Il y en a un qui n'est pas au top

Daniel