XL 2019 Amélioration d'un macro existante - Pas de temps - input box

Bastien43 · 18 Juillet 2021

Bonjour,

Je cherche à améliorer une macro. Voici la macro : https://www.excel-downloads.com/thr...s-dun-dossier-debogage.20058735/post-20442971

C'est super, grâce à @Dranreb cette macro me permet de simplifier le fichier (ci-joint) et de conserver un pas de temps de 15 min entre les valeurs.

Comment mettre une inputbox pour pouvoir saisir le pas de temps (1 min, 2, min, 5, 10 ou 15 min) ?

J'ai essayé de modifier cette instruction : Dim TRés(1 To 96, 1 To 2): LD = 1 avec Dim TRés(1 To pas, 1 To 2): LD = 1 en intégrant ceci :

Dim pasdetps As Integer
Dim pas As Integer

pasdetps = InputBox("Veuillez saisir le pas de temps svp (2 min, 5 min, 10 min, 15 min)", "Choix du pas de temps à appliquer", 15)

If pasdetps = "" Then Exit Function
If pasdetps = 2 Then pas = 720
If pasdetps = 5 Then pas = 288
If pasdetps = 10 Then pas = 144
If pasdetps = 15 Then pas = 96

mais j'ai un problème de "constante" dans l'expression Dim lors de l'exécution.

Comment faire svp ?
Je vous remercie pour votre aide.

La macro :

VB:

Sub TousQuartDHeuresTsFic()
   Dim NomFic As String, Wbk As Workbook
   ChDrive "C": ChDir "C:\Relevés" ' À adapter
   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

job75 · 21 Juillet 2021

Bonjour Bastien43, Bernard,

J'ai hésité à venir sur ce fil puisque Bernard s'en occupe. mais finalement je m'y suis mis.

Téléchargez les fichiers joints dans le même répertoire.

L'UserForm permet de choisir le pas :

VB:

Private Sub CommandButton1_Click() 'bouton OK
Dim i As Byte
For i = 1 To 5
    If Me("OptionButton" & i) Then pas = Val(Me("OptionButton" & i).Caption): Exit For
Next
Unload Me
End Sub

Le code dans Module1, la 1ère macro est affectée au bouton :

VB:

Public pas As Byte 'mémorise la variable

Sub Modifier_le_pas()
UserForm1.Show
If pas = 0 Then Exit Sub
Dim chemin$, dossier$, fichier$, nfich&, ext$
chemin = ThisWorkbook.Path & "\"
dossier = chemin & "Fichiers mofifiés\"
If Dir(dossier, vbDirectory) = "" Then MkDir...

Bastien43 · 20 Juillet 2021

Bonsoir @Dranreb , je vous relance svp. Une idée pour régler ce problème de dépassement de capacité ? Notamment si beaucoup de fichiers (250) et pas < 10 min ?
Merci pour votre aide
Cordialement

Dranreb · 20 Juillet 2021

Bonsoir.
Il faudrait que je sache sur quelle instruction vous avez un dépassement de capacité et quelles valeurs montreraient des espions sur les expressions impliquées.

Bastien43 · 20 Juillet 2021

Merci pour la réponse rapide
sur cette ligne : il y a "dépassement de capacité erreur 6"
TRés(LR, 2) = V0 + (V1 - V0) * (TpX - Tp0) / (Tp1 - Tp0)
Comment faire pour savoir quelles valeurs montreraient des espions sur les expressions impliquées?

Dranreb · 20 Juillet 2021

En sélectionnant une expression dans le code, puis clic droit, Ajouter un espion…
À tout les coup ce sont encore vos Tp0 et Tp1 qui n'ont pas été correctement initialisés.
Ah… Il y a peut être des temps en doubles dans votre fichier ?
Vous pouvez ajouter un test devant: If Tp1 > Tp0 Then TRés(LR, 2) = V0 + (V1 - V0) * (TpX - Tp0) / (Tp1 - Tp0)

Bastien43 · 20 Juillet 2021

Merci pour l'info, voici le résultat

Dranreb · 20 Juillet 2021

Interrogez aussi surtout Tp0, Tp1 et Tp1 - Tp0

Bastien43 · 20 Juillet 2021

ok merci,
je ne sais pas si c'est l'info recherchée...

Dranreb · 20 Juillet 2021

On dirait que le début de la plage à traiter est vide.

Bastien43 · 20 Juillet 2021

Cela peut venir d'un format de date ? pourtant avec un pas de 15 min cela passe

Dranreb · 20 Juillet 2021

Je ne sais pas il faudrait que vous joigniez le classeur avec les données
et aussi le classeur avec la programmation, que je voie si tout est correct.

Bastien43 · 20 Juillet 2021

merci,
Après plusieurs essai la macro est bonne. C'est un fichier qui a tout bloqué : le n°7
Voici le fichier problématique 7 et un fichier qui a été bien traité.
Comment faire pour avertir dans la macro ? Si une erreur sur un fichier, un msgbox pourrait afficher son nom ?
Encore merci pour votre temps

Dranreb · 20 Juillet 2021

Ça a l'air d'être les lignes à moité vides à la fin qui ont crée le problème

Bastien43 · 20 Juillet 2021

A oui effectivement, j'avais effectué un calcul ici et je n'ai pas vérifié ensuite... J'avais 2 fichiers à problèmes
En tout cas merci pour votre aide et votre temps. Encore merci pour la macro qui me facilite le travail.
Je vous remercie. J'ai appris plein de nouvelles astuces.
Bonne soirée

job75 · 21 Juillet 2021

Bonjour Bastien43, Bernard,

J'ai hésité à venir sur ce fil puisque Bernard s'en occupe. mais finalement je m'y suis mis.

Téléchargez les fichiers joints dans le même répertoire.

L'UserForm permet de choisir le pas :

VB:

Private Sub CommandButton1_Click() 'bouton OK
Dim i As Byte
For i = 1 To 5
    If Me("OptionButton" & i) Then pas = Val(Me("OptionButton" & i).Caption): Exit For
Next
Unload Me
End Sub

Le code dans Module1, la 1ère macro est affectée au bouton :

VB:

Public pas As Byte 'mémorise la variable

Sub Modifier_le_pas()
UserForm1.Show
If pas = 0 Then Exit Sub
Dim chemin$, dossier$, fichier$, nfich&, ext$
chemin = ThisWorkbook.Path & "\"
dossier = chemin & "Fichiers mofifiés\"
If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'crée le dossier
fichier = Dir(chemin & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        With Workbooks.Open(chemin & fichier)
            Modifier ActiveSheet 'lance la macro
            ext = Mid(fichier, InStrRev(fichier, "."))
            fichier = Left(fichier, Len(fichier) - Len(ext))
            .SaveAs dossier & fichier & " pas " & pas & " min" & ext
            .Close
        End With
    End If
    fichier = Dir
Wend
If nfich Then MsgBox nfich & " fichier" & IIf(nfich > 1, "s", "") & " modifié" & IIf(nfich > 1, "s...", "...")
End Sub

Sub Modifier(F As Worksheet)
Dim P As Range, deb&, fin&, resu(), i&, n&, j&, h&
F.Columns(1).Insert 'colonne auxilaire
Set P = F.[A1].CurrentRegion
P.Columns(1) = "=ROUND(1440*B1,0)" 'conversion en minutes
P(1) = 0
P.Sort P(1), xlAscending, Header:=xlYes 'tri de sécurité
deb = P(2, 1)
fin = Application.Max(P.Columns(1))
ReDim resu(1 To F.Rows.Count, 1 To 2)
For i = deb To fin Step pas
    n = n + 1
    resu(n, 1) = i / 1440
    j = Application.Match(i, P.Columns(1))
    If j + pas > P(j + 1, 1) And P(j + 1, 1) <> "" Then h = Application.Match(j + pas, P.Columns(1)) - j + 1 Else h = 2
    resu(n, 2) = Application.Forecast(i, P(j, 3).Resize(h), P(j, 1).Resize(h)) 'fonction PREVISION
    If IsError(resu(n, 2)) Or i = P(j, 1) Then resu(n, 2) = P(j, 3)
Next
F.Columns(1).Delete 'supprime la colonne auxiliaire
P(1, 1).EntireColumn.NumberFormat = "dd/mm/yyyy hh:mm"
P(2, 1).Resize(n, 2) = resu
P(2, 1).Offset(n).Resize(F.Rows.Count - n - 1, 2).ClearContents 'RAZ en dessous
End Sub

Les fichiers modifiés sont stockés dans le sous-dossier "Fichiers modifiés".

A+

Bastien43 · 22 Juillet 2021

Bonsoir merci beaucoup pour votre réponse.
Grâce à @Dranreb j'ai pu "bricoler" la macro et la mettre à jour.
Ici c'est aussi directement applicable et fiable.
Encore merci.

XL 2019 Amélioration d'un macro existante - Pas de temps - input box

Bastien43

XLDnaute Occasionnel

Pièces jointes

job75

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Bastien43

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Bastien43

XLDnaute Occasionnel

Discussions similaires