Insertion automatique d'une colonne des dates manquantes

[sandra131313]

Bonjour,

Je suis actuellement sur un fichier où sont répertoriées des dates dans la colonne A et il faudrait que je puisse avoir une insertion dans la colonne B des dates manquantes de la colonne A. On ne regarde pas si ce sont des jours ouvrés ou pas, on va au plus simple.

Le truc, c'est que même avec des forums, je suis perdue dans le process VB / VBA (les codes qu'il faut faire pour obtenir ce que je veux). Je suis plus que novice dans ce domaine. Je ne sais même pas où il faut aller à part dans l'onglet Développeur... Ca craint...

Je vous joins mon fichier, en croisant les doigts de trouver une bonne âme qui saurait faire cela, s'il vous plaît ?

Merci infiniment, car sinon, je dois tout taper à la main... J'ai pas fini...

 

[klin89]

Bonsoir sandra131313

A tester sur quelques dates

Option Explicit
Sub test()
Dim a, debut As Date, fin As Date, i As Long, n As Long, e, y
    'Application.ScreenUpdating = False
    With Sheets(1)
        a = .Range("a2", .Range("a" & Rows.Count).End(xlUp)).Value
        debut = Int(.Range("a2").Value)
        fin = Int(.Range("a" & Rows.Count).End(xlUp).Value)
    End With
    With CreateObject("Scripting.Dictionary")
        For i = debut To fin
            .Item(i) = Empty
        Next
        For i = 2 To UBound(a, 1)
            If .exists(Int(a(i, 1))) Then
                .Item(Int(a(i, 1))) = True
            End If
        Next
        For Each e In .keys
            If Not IsEmpty(.Item(e)) Then .Remove e
        Next
        n = .Count: y = .keys
        If n Then
            With Sheets(1).Range("c1").Resize(n, 1)
                .NumberFormat = "m/d/yyyy"
                .FormulaLocal = Application.Transpose(y)
            End With
        End If
    End With
    'Application.ScreenUpdating = True
End Sub

klin89

 

[sandra131313]

Option Explicit
Sub test()
Dim a, debut As Date, fin As Date, i As Long, n As Long, e, y
'Application.ScreenUpdating = False
With Sheets(1)
a = .Range("a2", .Range("a" & Rows.Count).End(xlUp)).Value
debut = Int(.Range("a2").Value)
fin = Int(.Range("a" & Rows.Count).End(xlUp).Value)
End With
With CreateObject("Scripting.Dictionary")
For i = debut To fin
.Item(i) = Empty
Next
For i = 2 To UBound(a, 1)
If .exists(Int(a(i, 1))) Then
.Item(Int(a(i, 1))) = True
End If
Next
For Each e In .keys
If Not IsEmpty(.Item(e)) Then .Remove e
Next
n = .Count: y = .keys
If n Then
With Sheets(1).Range("c1").Resize(n, 1)
.NumberFormat = "m/d/yyyy"
.FormulaLocal = Application.Transpose(y)
End With
End If
End With
'Application.ScreenUpdating = True
End Sub

 

[sandra131313]

Cher klin89

J'ai testé ton code avec le peu que je savais pour le coller dans le VB, et ça a marché !

Tu ne sais pas à quel point tu m'as ôté une épine du pied. Je suis admirative de tant de talent.

Merci infiniment !!!!!

Sandra

 

[job75]

Bonjour sandra131313, klin89,

Par curiosité j'ai voulu voir ce que ça pouvait donner sans Dictionary.

Eh bien cette macro s'exécute chez moi en 29 millièmes de seconde sur le fichier joint :

Sub TestSansDictionary()
Dim mini&, maxi&, a, t, i&
Application.ScreenUpdating = False
mini = Int(Application.Min([A:A])) - 1
maxi = Int(Application.Max([A:A]))
[C:C].ClearContents 'RAZ
If maxi - mini > 1 Then
  [C1] = CDate(mini + 1) 'date de départ
  With [C1].Resize(maxi - mini)
    .DataSeries Type:=xlChronological, Date:=xlDay 'remplissage
    a = .Value
    t = [A1].CurrentRegion
    For i = 2 To UBound(t)
      a(Int(t(i, 1)) - mini, 1) = ""
    Next
    .Value = a
    .Sort [C1], xlAscending, Header:=xlNo 'tri
  End With
End If
End Sub

Alors que la macro de klin89 (par ailleurs très bien) s'exécute en 47 millièmes de seconde.

Edit : j'ajoute le fichier pour tester les durées (1000 boucles).

A+

 

[job75]

Re,

En fait il faut utiliser autrement le Dictionary :

Sub Test_job75()
Dim mini&, maxi&, a() As Date, t, d As Object, i&, n&
Application.ScreenUpdating = False
mini = Int(Application.Min([A:A]))
maxi = Int(Application.Max([A:A]))
[C:C].ClearContents 'RAZ
If maxi > mini Then
  ReDim a(1 To maxi - mini, 1 To 1)
  t = [A1].CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(t)
    d(Int(t(i, 1))) = ""
  Next
  n = 0 'pas nécessaire ici (un seul passage)
  For i = mini + 1 To maxi - 1
    If Not d.exists(i) Then n = n + 1: a(n, 1) = i
  Next
  If n Then [C1].Resize(n) = a
End If
End Sub

Fichier (2), durée d'exécution 24 millièmes de seconde.

A+

 

[sandra131313]

Bonjour sandra131313, klin89,

Par curiosité j'ai voulu voir ce que ça pouvait donner sans Dictionary.

Eh bien cette macro s'exécute chez moi en 29 millièmes de seconde sur le fichier joint :

Sub TestSansDictionary()
Dim mini&, maxi&, a, t, i&
Application.ScreenUpdating = False
mini = Int(Application.Min([A:A])) - 1
maxi = Int(Application.Max([A:A]))
[C:C].ClearContents 'RAZ
If maxi - mini > 1 Then
  [C1] = CDate(mini + 1) 'date de départ
  With [C1].Resize(maxi - mini)
    .DataSeries Type:=xlChronological, Date:=xlDay 'remplissage
    a = .Value
    t = [A1].CurrentRegion
    For i = 2 To UBound(t)
      a(Int(t(i, 1)) - mini, 1) = ""
    Next
    .Value = a
    .Sort [C1], xlAscending, Header:=xlNo 'tri
  End With
End If
End Sub

Alors que la macro de klin89 (par ailleurs très bien) s'exécute en 47 millièmes de seconde.

Edit : j'ajoute le fichier pour tester les durées (1000 boucles).

A+

 

[sandra131313]

Merci à tous de vous être impliqués ainsi, cela m'a sauvé d'un sacré travail de fourmi infini !

Vous êtes des chefs bienveillants.

MERCI INFINIMENT !!