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

B

Bastien43

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

Pièces jointes

  • 6158.xls
    41 KB · Affichages: 15
Dernière édition:
Solution
job75
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...
Trier par date Trier par votes
mutzik

mutzik

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
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
…
 
Vote positif 0 Vote négatif
B

Bastien43

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
B

Bastien43

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
B

Bastien43

XLDnaute Occasionnel
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
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Sergent_Lipton
  • Résolu(e)
Microsoft 365 [VBA] Barre de recherche dynamique - objectif : cacher les lignes hors résultat
Réponses
3
Affichages
181
Sergent_Lipton
Sergent_Lipton
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
215
guiyom
G
G
  • Question
Microsoft 365 Transfert de données
Réponses
7
Affichages
328
GClaire
G
B
  • Question
XL 2021 Insertions de plus de 10 textbox et combobox dans listbox
Réponses
9
Affichages
538
cp4
cp4
V
  • Résolu(e)
XL 2016 Exportation au format PDF à l'aide d'une macro : erreur 1004 'Document non enregistré'
Réponses
14
Affichages
489
Phil69970
Phil69970
GADENSEB
  • Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
458
GADENSEB
GADENSEB
V
  • Résolu(e)
XL 2021 Complétion d'un tableau automatisée
Réponses
9
Affichages
652
VincentH.DR
V
K
  • Question
Macro pour aller chercher des données d'un autre excel vers le fichier de la macro.
Réponses
2
Affichages
910
AtTheOne
AtTheOne
B
  • Question
XL 2019 Macro - Envoyer des mails depuis un tableau de données
Réponses
3
Affichages
743
AtTheOne
AtTheOne
D
  • Question
XL 2019 Aide à la compréhension d'un code VBA
Réponses
4
Affichages
706
Dudu2
Dudu2

Membres actuellement en ligne

23 membres et 138 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 115
Messages
2 085 448
Membres
102 889
dernier inscrit
monsef JABBOUR