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

Bastien43

XLDnaute Occasionnel
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é.


VB:
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
 

Pièces jointes

  • 1. Débit.zip
    104.6 KB · Affichages: 10
Dernière édition:
Solution
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.
VB:
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...

Dranreb

XLDnaute Barbatruc
VB:
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

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • Traitement.zip
    123.7 KB · Affichages: 2

Dranreb

XLDnaute Barbatruc
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.
VB:
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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+
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 011
Membres
101 866
dernier inscrit
XFPRO