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...

mutzik · 18 Juillet 2021

bjr, et si tu déclares dim pasdetps sans mettre as integer, ça donne quoi
parceque inputbox renvoie du texte (si mes souvenirs sont bons.
donc : le meilleur est de faire :
dim pasdetps
If pasdetps = "" Then Exit Function
If pasdetps * 1 = 2 Then pas = 720
ici pasdetps est converti en numérique en faisant *1

Dranreb · 18 Juillet 2021

Bonsoir.

Essayez :

VB:

   Dim TRés(), LRMax As Long, PasTps As Double
…
   PasTps =InputBox("Veuillez saisir le pas de temps svp (2 min, 5 min, 10 min, 15 min)", "Choix du pas de temps à appliquer", 15)
   LRMax = Int(1440 / PasTps + 0.5)
   ReDim TRés(1 To LRMax, 1 To 2)
   For LR = 1 To LRMax
      TpX = Dt + (LR - 1) / LRMax: TRés(LR, 1) = TpX
…

Bastien43 · 18 Juillet 2021

Bonsoir,

Merci @mutzik j'ai toujours une erreur lors de l'exécution, merci pour votre aide

@Dranreb j'ai essayé mais j'ai une erreur 6 : dépassement de capacité sur cette ligne : TRés(LR, 2) = V0 + (V1 - V0) * (TpX - Tp0) / (Tp1 - Tp0)

Ai-je fais une erreur dans le code ?

Si j'enlève le commentaire pour :

Code:

   Tp0 = TDon(LD, 1): V0 = TDon(LD, 2): LD = 2
   Tp1 = TDon(LD, 1): V1 = TDon(LD, 2)
   Dt = Int(Tp0)

il y a aussi une erreur

Merci pour votre aide
Bonne soirée

VB:

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
   Dim TRés(), LRMax As Long, PasTps As Double
        
   PasTps = InputBox("Veuillez saisir le pas de temps svp (2 min, 5 min, 10 min, 15 min)", "Choix du pas de temps à appliquer", 15)
   LRMax = Int(1440 / PasTps + 0.5)
   ReDim TRés(1 To LRMax, 1 To 2)
 
   '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 LRMax
      TpX = Dt + (LR - 1) / LRMax: 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

Dranreb · 18 Juillet 2021

Il ne fallait pas mettre en commentaires les instructions d'initialisation de Tp0, Tp1 et Dt.

Bastien43 · 18 Juillet 2021

Bonsoir,

ok merci, cependant j'ai lerreur 9 l'indice n'appartient pas à la sélection sur cette ligne lors de l'execution

Tp0 = TDon(LD, 1):

Qu'est ce que cela signifie ?

Merci

Dranreb · 18 Juillet 2021

Initialisez LD = 1 juste avant cette initialisation ou juste derrière le Redim

VB:

   ReDim TRés(1 To LRMax, 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)

Bastien43 · 18 Juillet 2021

Cela fonctionne merci
Cependant si il y a plusieurs fichiers dans le dossier cela me redemande à chaque fichier le pas de temps
Comment faire pour avoir une seule fois la question sur le pas de temps ?
Encore merci pour votre temps

Dranreb · 18 Juillet 2021

À ce compte là transmettez ce pas en argument à la procédure et saisissez le dans la procédure appelante.

Bastien43 · 18 Juillet 2021

merci
bon je bloque je ne sais pas faire
J'ai l'erreur argument non facultatif...

Dranreb · 18 Juillet 2021

Oui ben il faut le transmettre lors de l'appel :

VB:

TousQuartDHeures Wbk.Worksheets(1).[A1].CurrentRegion, Interval

Bastien43 · 19 Juillet 2021

Toujours bloqué désolé

VB:

Sub TousQuartDHeuresTsFic()
  
   Dim NomFic As String, Wbk As Workbook
   Dim nfich&
   Dim PasTps As Double
    
   If MsgBox("Avez-vous fait une copie des fichiers avant de commencer ?", vbYesNo) = vbNo Then Exit Sub
 
   ChDrive "C": ChDir Selection_Dossier ' À adatper
   NomFic = Dir("*.xl*")
  
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False 'si un fichier est déjà ouvert
  
   PasTps = InputBox("Veuillez saisir le pas de temps svp (2 min, 5 min, 10 min, 15 min)", "Choix du pas de temps à appliquer", 15)
  
   Barre_Avancement.afficher
   NbFic = 0
  
   Do While NomFic <> ""
  
      nfich = nfich + 1
      
      Set Wbk = Workbooks.Open(NomFic)
      TousQuartDHeures Wbk.Worksheets(1).[A1].CurrentRegion, PasTps
      Wbk.Close SaveChanges:=True
      
      Barre_Avancement.actualiser CInt((nfich / 108) * 100)
      
      NomFic = Dir: Loop
      
   If nfich Then MsgBox nfich & " fichier" & IIf(nfich > 1, "s", "") & " traité" & IIf(nfich > 1, "s...", "...") & "et pas de 15 minutes mis à jour !"
  
   Unload Barre_Avancement
    
   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
   Dim TRés(), LRMax As Long, PasTps As Double
   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

          
   PasTps = InputBox("Veuillez saisir le pas de temps svp (2 min, 5 min, 10 min, 15 min)", "Choix du pas de temps à appliquer", 15)
   LRMax = Int(1440 / PasTps + 0.5)
   ReDim TRés(1 To LRMax, 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 LRMax
      TpX = Dt + (LR - 1) / LRMax: 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

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
        Selection_Dossier = .SelectedItems(1)
        If Err.Number <> 0 Then Selection_Dossier = False

    End With

End Function

Dranreb · 19 Juillet 2021

VB:

Sub TousQuartDHeures(ByVal Rng As Range, ByVal PasTps As Double)

C'est de moins en moins clair avec toutes ces lignes vide inutiles. Enfin je trouve …

Bastien43 · 19 Juillet 2021

Dranreb à dit:
VB:

Sub TousQuartDHeures(ByVal Rng As Range, ByVal PasTps As Double)

C'est de moins en moins clair avec toutes ces lignes vide inutiles. Enfin je trouve …

Merci pour votre aide,
effectivement je vais remettre de l'ordre demain
j'espère comprendre mieux car je me retrouve de nouveau avec "dépassement de capacité"
encore merci pour votre temps
bonne soirée

Bastien43 · 19 Juillet 2021

Bonsoir @Dranreb
j'ai finalement réussi, effectivement le fichier n'était pas clair.
Merci pour votre aide et vos réponses
J'ai une autre question @Dranreb : si j'ai beaucoup de fichiers, le message affiche une erreur 6 "dépassement de capacité" sur cette ligne :
TRés(LR, 2) = V0 + (V1 - V0) * (TpX - Tp0) / (Tp1 - Tp0)

Il y a -t-il une solution ? peut être les variable de type "double" sont la cause ?
Bonne soirée

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

Bastien43

XLDnaute Occasionnel

Pièces jointes

job75

mutzik

XLDnaute Barbatruc

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

Bastien43

XLDnaute Occasionnel

Discussions similaires