XL 2019 Appliquer une macro à plusieurs fichiers d'un dossier - Débogage ?

[Bastien43]

Bonjour,

J'essaie d'appliquer une macro à tous les fichiers contenus dans un dossier.

La macro permet de supprimer les lignes dans un fichier Excel et de conserver un pas de temps de 15 minutes (voir ci-joint l'explication concernant le pas de temps : https://www.excel-downloads.com/threads/suppression-multiple-de-lignes-macro.20057548/post-20433583 )

J'ai créé une nouvelle macro mais cela ne fonctionne pas . Je la joins ici et les documents à "simplifier" en pièce jointe.

L'idée est de lancé la macro à partir d'un fichier Excel et de mettre à jour les documents dans le dossier sélectionné.

Sub Modifier_Pas()

    Dim i As Integer
    Dim Chemin As String
    Dim tablo, i&, dat$, min%, n&
   
   
    Chemin = Selection_Dossier

    'manque une étape
   
        tablo = [A1].CurrentRegion.Resize(, 2) 'feuille active
        For i = 1 To UBound(tablo)
            dat = Format(tablo(i, 1), "mm/dd/yyyy hh:mm") 'date au format US
            min = Val(Right(dat, 2))
            If min Mod 15 = 0 Then n = n + 1: tablo(n, 1) = dat: tablo(n, 2) = tablo(i, 2)
        Next
        '---restitution---
        Application.ScreenUpdating = False
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
        Columns("A:B").ClearContents 'RAZ
        [A1].Resize(n, 2) = tablo '1ère cellule de destination, à adapter
        [A1].Resize(n, 2).RemoveDuplicates Array(1, 2), Header:=xlYes 'supprime les doublons en colonnes A et B (ce n'est pas obligatoire)
        With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
       
End Sub
   
   
Function Selection_Dossier() As Variant

    '1 ouvrir un fichier
    '2 enregistrement de fichier
    '3 sélection de fichier
    '4 sélection de dossier
    With Application.FileDialog(4)

        .Show
        On Error Resume Next 'si annuler
        Dossier = .SelectedItems(1)
        If Err.Number <> 0 Then Dossier = False

    End With

End Function

Je vous remercie pour votre aide.
Cordialement
Bastien

 

[Bastien43]

Re-bonjour,

Svp, quelqu'un peut-il m'aider ? il me manque une étape. L'ouverture de chaque fichier, la modif et la fermeture/sauvegarde je pense.

Je vous remercie,
Cordialement
Bastien

 

[Dranreb]

Bonjour.

Dim Wbk As Workbook
…
   Set Wbk = Workbooks.Open(NomCheminClasseur)
   …
   Wbk.Close SaveChanges:=True

 

[Bastien43]

Bonjour
Merci pour votre réponse
Comment l'intégrer à une boucle ? Pour traiter tous les fichiers l'un après l'autre ?
Comment l'appliquer à chaque fichier Excel ?

While chemin <> ""

??

Merci pour votre aide

 

[Dranreb]

Sub TousQuartDHeuresTFic()
   Dim NomFic As String, Wbk As Workbook
   ChDrive "C": ChDir "C:\Relevés" ' À adatper
   NomFic = Dir("*.xl*")
   Do While NomFic <> ""
      Set Wbk = Workbooks.Open(NomFic)
      TousQuartDHeures Wbk.Worksheets(1).[A1].CurrentRegion
      Wbk.Close SaveChanges:=True
      NomFic = Dir: Loop
   End Sub
Sub TousQuartDHeures(ByVal Rng As Range)
…

 

[job75]

Bonjour Bastien43, Bernard,

Téléchargez les fichiers zippés joints dans le même dossier.

La macro affectée au bouton du fichier .xlsm :

Sub Traiter_fichiers()
Dim chemin$, fichier$, nfich&, tablo, n&, i&, dat$, min%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        With Workbooks.Open(chemin & fichier).Sheets(1)
            tablo = [A1].CurrentRegion.Resize(, 2)
            n = 0
            For i = 2 To UBound(tablo)
                dat = Format(tablo(i, 1), "mm/dd/yyyy hh:mm") 'date au format US
                min = Val(Right(dat, 2))
                If min Mod 15 = 0 Then n = n + 1: tablo(n, 1) = dat: tablo(n, 2) = tablo(i, 2)
            Next
            '---restitution---
            If .FilterMode Then .ShowAllData 'si la feuille est filtrée
            .Columns("A:B").ClearContents 'RAZ
            .[A1].Resize(n, 2) = tablo
            .[A1].Resize(n, 2).RemoveDuplicates Array(1, 2), Header:=xlYes 'supprime les doublons en colonnes A et B (ce n'est pas obligatoire)
            .Parent.Close True 'enregistre et ferme le fichier
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
If nfich Then MsgBox nfich & " fichier" & IIf(nfich > 1, "s", "") & " traité" & IIf(nfich > 1, "s...", "...")
End Sub

A+

 

[Dranreb]

De mon coté j'ai écrit depuis ma Sub TousQuartDHeures avec une interpolation linéaire entre les valeurs fournies. J'ignore si c'est ce qu'il vous fallait.

Sub TousQuartDHeuresTsFic()
   Dim NomFic As String, Wbk As Workbook
   ChDrive "C": ChDir "C:\Relevés" ' À adatper
   NomFic = Dir("*.xl*")
   Do While NomFic <> ""
      Set Wbk = Workbooks.Open(NomFic)
      TousQuartDHeures Wbk.Worksheets(1).[A1].CurrentRegion
      Wbk.Close SaveChanges:=True
      NomFic = Dir: Loop
   End Sub
Sub TousQuartDHeures(ByVal Rng As Range)
   Dim TDon(), Dt As Date, LD As Long, Tp0 As Date, V0 As Double, _
      Tp1 As Date, V1 As Double, LR As Long, TpX As Date
   Set Rng = Rng.Rows(2).Resize(Rng.Rows.Count - 1, 2)
   TDon = Rng.Value
   Dim TRés(1 To 96, 1 To 2): LD = 1
   Tp0 = TDon(LD, 1): V0 = TDon(LD, 2): LD = 2
   Tp1 = TDon(LD, 1): V1 = TDon(LD, 2)
   Dt = Int(Tp0)
   For LR = 1 To 96
      TpX = Dt + (LR - 1) / 96: TRés(LR, 1) = TpX
      Do While Tp1 < TpX And LD < UBound(TDon, 1)
         Tp0 = Tp1: V0 = V1: LD = LD + 1: Tp1 = TDon(LD, 1): V1 = TDon(LD, 2)
         Loop
      TRés(LR, 2) = V0 + (V1 - V0) * (TpX - Tp0) / (Tp1 - Tp0)
      Next LR
   Rng.ClearContents
   Rng.Resize(96, 2).Value = TRés
   End Sub

 

[Bastien43]

Bonsoir,

Merci beaucoup pour votre aide.

@job75 la macro fonctionne merci. Parfois le pas "saute" et passe à 30 min (fichier 2) et "saute" aussi un 1/4 d'heure (45 min, ligne 69/70 du fichier 3). est-ce possible d'ajuster ou est-ce ainsi ?

@Dranreb C'est génial cela fonctionne super bien merci beaucoup

Bonne soirée
Cordialement

 

[job75]

Bonjour Bastien43, Bernard,

@job75 la macro fonctionne merci. Parfois le pas "saute" et passe à 30 min (fichier 2) et "saute" aussi un 1/4 d'heure (45 min, ligne 69/70 du fichier 3). est-ce possible d'ajuster ou est-ce ainsi ?

C'est ainsi car ma macro se contente de récupérer les 1/4 d'heures existants.

Alors que La macro de Bernard calcule les valeurs par interpolation.

A+

 

[Bastien43]

Bonjour
A ok je comprends
Merci pour l'explication
Cordialement