Erreur '6' Dépassement de capacité
Résolu
TraderAS
Messages postés
119
Statut
Membre
-
TraderAS Messages postés 119 Statut Membre -
TraderAS Messages postés 119 Statut Membre -
Bonjour,
Je souhaite insérer automatiquement les dates manquantes voici le fichier excel sur lequel je travail: https://www.cjoint.com/c/CDiosKpPr2C
une personne m'a aidé à avoir ce code sauf que he trouve lors de l'éxecution de ce code Erreur '6' Dépassement de capacité
voici le code
Option Explicit
Sub Remplissage()
Dim LastLig As Long, i As Long, j As Long, k As Long, m As Long
Dim n As Integer
Dim Tb, Res()
Application.ScreenUpdating = False
With Worksheets("Test")
LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
Tb = .Range("A2:B" & LastLig)
ReDim Res(1 To 2, 1 To 1)
Res(1, 1) = CLng(Tb(1, 1))
Res(2, 1) = Tb(1, 2)
j = 1
For i = 2 To LastLig - 1
n = Diff(Tb, i)
m = j + n
ReDim Preserve Res(1 To 2, 1 To m)
For k = j + 1 To m
Res(1, k) = Suiv(Res(1, k - 1))
Res(2, k) = IIf(n = 1 Or k = m, Tb(i, 2), Tb(i - 1, 2))
Next k
j = m
Next i
With .Range("B2")
.Resize(j, 2) = Application.Transpose(Res)
.Resize(j, 1).NumberFormat = "dd/mm/yyyy"
End With
End With
End Sub
Private Function Diff(ByVal T, ByVal d As Long) As Byte
Dim Dte As Long, Der As Long
Der = CLng(T(d - 1, 1))
Dte = CLng(T(d, 1))
Diff = Evaluate("=NETWORKDAYS(" & Der & "," & Dte & ")") - 1
End Function
Private Function Suiv(ByVal Dte As Long) As Long
Suiv = Evaluate("=WORKDAY(" & Dte & ",1)")
End Function
merci
Je souhaite insérer automatiquement les dates manquantes voici le fichier excel sur lequel je travail: https://www.cjoint.com/c/CDiosKpPr2C
une personne m'a aidé à avoir ce code sauf que he trouve lors de l'éxecution de ce code Erreur '6' Dépassement de capacité
voici le code
Option Explicit
Sub Remplissage()
Dim LastLig As Long, i As Long, j As Long, k As Long, m As Long
Dim n As Integer
Dim Tb, Res()
Application.ScreenUpdating = False
With Worksheets("Test")
LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
Tb = .Range("A2:B" & LastLig)
ReDim Res(1 To 2, 1 To 1)
Res(1, 1) = CLng(Tb(1, 1))
Res(2, 1) = Tb(1, 2)
j = 1
For i = 2 To LastLig - 1
n = Diff(Tb, i)
m = j + n
ReDim Preserve Res(1 To 2, 1 To m)
For k = j + 1 To m
Res(1, k) = Suiv(Res(1, k - 1))
Res(2, k) = IIf(n = 1 Or k = m, Tb(i, 2), Tb(i - 1, 2))
Next k
j = m
Next i
With .Range("B2")
.Resize(j, 2) = Application.Transpose(Res)
.Resize(j, 1).NumberFormat = "dd/mm/yyyy"
End With
End With
End Sub
Private Function Diff(ByVal T, ByVal d As Long) As Byte
Dim Dte As Long, Der As Long
Der = CLng(T(d - 1, 1))
Dte = CLng(T(d, 1))
Diff = Evaluate("=NETWORKDAYS(" & Der & "," & Dte & ")") - 1
End Function
Private Function Suiv(ByVal Dte As Long) As Long
Suiv = Evaluate("=WORKDAY(" & Dte & ",1)")
End Function
merci
3 réponses
-
Bonjour,
Sans vraiment comprendre le calcul je relève deux anomalies dans la fonction Diff.
Voici les deux corrections en gras :
Private Function Diff(ByVal T, ByVal d As Long) As Long
Dim Dte As Long, Der As Long
Der = CLng(T(d - 1, 1))
Dte = CLng(T(d, 1))
Diff = Evaluate("=NETWORKDAYS(" & Dte & "," & Der & ")") - 1
End Function
Je ne sais pas si c'est normal mais il tentait de calculer des nombres de jours négatifs (sans doute parce que les dates sont en ordre décroissant).
A voir si le résultat est bon
A+-
-
-
Voila, mais bon quand j'ai appliqué le code ca marché avec votre correction, mais le résultat n'est pas le résultat souhaité, en faite je veux insérer les lignes des dates manquante dans l'historique que j'ai :
comme suit:
DATE Valeur
20/03/2011 10
18/03/2011 15
16/03/2011 13
14/03/2011 12
comme vous pouvez le constatez il manque les dates du 19,17 et le 15 Mars 2013, je souhaite les insérer automatiquement et copier coller la valeur de la date qui précéde c'est à dire et comme exemple:
===>j'insére la ligne de la date du 19/03/2013 et je fais un copier coller de la valeur du 18/03/2013 et ains de suite
j'ai crée cee code mais ca n'a pas marché :
Sub date_creation()
Dim i As Integer
Dim fin As Integer
For i = 1 To 10
If Cells(i, 1) = "" Then fin = i: Exit For
Next i
For i = 1 To fin
If Cells(i + 1, 1) <> SERIE.JOUR.OUVR(Cells(i, 1).Value, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
Next i
End Sub
==> Erreur d'éxecution '424' objet recquis au niveau de cette ligne:
****If Cells(i + 1, 1) <> SERIE.JOUR.OUVR(Cells(i, 1).Value, 1) Then****
vu que je travail sur une semaine de 5 jours
et voici le document sur lequel je travail :
https://www.cjoint.com/c/CDiosKpPr2C
est ce que vous pouvez me donnez un coup de main a avoir le bon résultat
merci -
-
-
-
Voici une solution inspiré de la macro date_création
Sub date_creation() Dim i As Integer Dim fin As Integer fin = Cells(Rows.Count, 1).End(xlUp).Row For i = fin - 1 To 1 Step -1 If Cells(i + 1, 1) <> WorksheetFunction.WorkDay(Cells(i, 1).Value, 1) Then Rows(i + 1).Insert Cells(i + 1, 1) = WorksheetFunction.WorkDay(Cells(i, 1).Value, 1) Cells(i + 1, 2) = Cells(i, 2) i = i + 2 End If Next i End Sub
EDIT: après test je viens de corriger une erreur et de modifier la macro qui ne marchait pas bien lorsque plusieurs jours consécutifs manquaient
Trois remarques :
1/ il faut que les dates soient en ordre croissant
2/ cela ne tient pas compte des jours fériés.
3/ attention la liste initiale ne doit comporter que des jours ouvrés sinon le comportement est incorrect.
Cordialement, -
Bonjour,
j'ai appliqué le code, il a tourné sans aucune lilite d'arrêt voici le fichier surlequel j'ai travaillé, les 3 conditions que vous avez imposées sont respectées mais le code ne fait que tourner
voici le fichier: https://www.cjoint.com/?CDlkaOxBDcM-
Bonjour,
Je crois que je me suis mal exprimé, les dates doivent être en ordre croissant c'est à dire la plus ancienne date en A1 d'abord vers la date la plus récente. Si vous re-triez votre colonne dans cet ordre cela fonctionne.
Si vous souhaitez que cela puisse fonctionner dans l'ordre inverse je peux modifier le code.
Cordialement, -
Re
voici le code, et ca marche mais seulement pour un nombre limité de lignes à modifier
Sub date_creation()
Dim i As Integer
Dim fin As Integer
fin = Cells(Rows.Count, 1).End(xlUp).Row
For i = fin To 2 Step -1
If Cells(i - 1, 1) <> WorksheetFunction.WorkDay(Cells(i, 1).Value, 1) Then
Rows(i).Insert
Cells(i, 1) = WorksheetFunction.WorkDay(Cells(i + 1, 1).Value, 1)
Cells(i, 2) = Cells(i + 1, 2)
i = i + 1
End If
Next i
End Sub
Quand j'ai voulu testé ca n'a marché que sur une plage de données qui composée de presque 20 lignes mais quand j'ai essayé de l'appliquer sur des données composées de presque 300 lignes, et où il manque des dates, il a commencé à m'ajouter des dates futures, au dela de 2013, c'est à dire il a ajouté les dates de 2014, 2015 etc
il manque une petite rectif afin de limiter son champs d'action qu'à seulement les données disponibles ni plus ni moin peut être une variable k qui varie entre 1 et le nombre de lignes
ci joint le fichier qui contient un grand nombre de lignes
Merci pour votre précieuse aide ;) -
Voila une correction à tester :
Sub date_creation() Dim i As Integer Dim fin As Integer fin = Cells(Rows.Count, 1).End(xlUp).Row For i = fin To 3 Step -1 If Cells(i - 1, 1) <> WorksheetFunction.WorkDay(Cells(i, 1).Value, 1) Then Rows(i).Insert Cells(i, 1) = WorksheetFunction.WorkDay(Cells(i - 1, 1).Value, -1) Cells(i, 2) = Cells(i - 1, 2) i = i + 1 End If Next i End Sub
-
-
