Erreur '6' Dépassement de capacité [Résolu/Fermé]

Signaler
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
-
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
-
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

3 réponses

Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
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+
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
Salut pilas 31,
effectivement on essaye de faire la différence entre deux dates, qui sont supposées être ordonnées par ordre croissant
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
D'accord. d'où l'inversion de Dte et Der. En fait quand le résultat est négatif il y dépassement de capacité du format Byte.
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
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
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
OK je regarde.
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
Merci
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
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,
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
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
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
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,
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
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 ;)
Messages postés
1823
Date d'inscription
vendredi 5 septembre 2008
Statut
Contributeur
Dernière intervention
24 avril 2020
586
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
Messages postés
110
Date d'inscription
lundi 3 décembre 2012
Statut
Membre
Dernière intervention
26 avril 2018
1
Ca marche pilas ;)
vraiment merci pour votre préciseuse aide