[XL-2010] Boucle qui ne boucle pas

[Excelnaute]

Bonsoir à tous,

Débutant en VBA j'ai construit un petit fichier sous excel 2010 pour gérer des validations de formations.
Le but du jeu est de saisir dans la partie droite d'un tableau, des dates qui accréditent qu'une formation est bien validée depuis le jour x.
Si il y a des validations à J je fais en sorte que le programme le détecte, et les marquent en vert. A partir de ce stade j'aimerais faire en sorte que les lignes correspondant aux saisies du jour, soient copiées de façon transparente (fermeture de la macro/module/feuille par exemple) vers une feuille servant d'archivage des saisies.
Donc, par rapport à mon exemple,
A partir de la feuille Tableau je voudrais copier les lignes dont les cellules (non contiguës définies par vrange), contiennent la date du jour vers la feuille archive.Le résultat trouve (si on saisit une date du jour) et copie bien le 1er enregistrement qui correspond à la recherche find (date) vers la feuille archive à la première ligne vide mais hélas pour moi s'arrête là sans passer aux enregistrements suivants que se soit en lecture et en écriture avec un message d'erreur 438 (PROPRIETE METHODE NON GEREE PAR CET OBJET) sur findnext().
Merci de m'aider à sortir de cette... boucle qui ne boucle pas car je n'en vois pas la solution.

Cordialement.

[jfontaine]

Bonjour,

Peux tu nous mettre a disposition le code

[Excelnaute]

Merci de votre réponse,

Voilà donc le code de la procédure.
Cordialement,

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Sub SEL_AMDE1()
'
Dim agts, total, Drange, coord As Variant
Dim cellule As Range
Dim verdate As Date
Dim cpt, visible As Long
' SEL_AMDE1 Macro
'
    Sheets("GESTION").Select
    Range("d3:h3").ClearContents
    Worksheets("GESTION").AutoFilterMode = False
    Range("Z3:AA3").Select
    Selection.Copy
    ActiveWindow.SmallScroll ToRight:=-6
    Range("D3").Select
    ActiveSheet.Paste
    Range("f3").Value = Range("Y3").Value
    agts = Evaluate("=subtotal(3,A:A)")
    ActiveWindow.SmallScroll Down:=-364
    ActiveSheet.Range("$A$14:$t$" & agts).AutoFilter field:=5, Criteria1:="1"
    visible = Evaluate("=subtotal(3,A:A)")
    Range("g3").Value = visible
 
  'Selection colonnes dates de validation
 
  ' cpt = 0 optionnel compteur de validation 
  MsgBox ("Visible=" & visible)
  vrange = ("k15:k" & agts & ",m15:m" & agts & ",o15:o" & agts & ",q15:q" & agts & ",s15:s" & agts)
  Range(vrange).Select
  'Recherche des cellules  avec la date du jour
  For Each cell In Selection
  If cell.Value = "" Then
  Else
  If cell.Value = Date Then
                'cpt = cpt + 1
                cell.Select
             With Selection.Interior
            .ColorIndex = 4
            .Pattern = xlSolid
        End With
        Else
        End If
End If
Next
 
 
'If cpt = 0 Then
'MsgBox ("Pas de mise à jour effectuée aujourdhui")'
'Selection.Interior.ColorIndex = 0
'Else
  'selectionner les lignes qui ont des validites à la date du jour
  Select Case MsgBox(cpt & " validation(s) (a) ont été faite(s) aujourdhui, envoyer un recap ? ", vbYesNo)
 
Case vbYes
' Info_Formation Macro
  cpt = 0
  Dim cdest As Variant
  Dim c As Variant
 
  With Worksheets("RECAP")
  .AutoFilterMode = False
  Set cdest = .Cells(.Rows.Count, "A").End(xlUp)(2)
  End With
 
  x = Range("$A$14:$t$" & visible)
  With Worksheets("GESTION")
  .Range("$A$14:$t$" & visible).AutoFilter field:=5, Criteria1:="1"
  ' Set c = .Range(vrange).SpecialCells(xlCellTypeVisible).Find(Date, LookIn:=xlValues)
  Set c = .Range(vrange).SpecialCells(xlCellTypeVisible).Find(Date, LookIn:=xlFormulas)
 If Not c Is Nothing Then
  adr = c.Address
  MsgBox (adr & c)
  Do
  With c.EntireRow
  .Copy cdest
  ' cpt = cpt + 1 sert de compteur pour chaque controleur
 
  End With
 
 Set c = .FindNext(c)
  Loop While Not c Is Nothing
  End If
  End With
 
    Case vbNo
    MsgBox ("Action annulée")
  End Select
'End If
End Sub