Objet requis 429

Version imprimable

Objet requis 429

Bonjour,

J'en ai marre à cannard, rien ne marche dès que j'essaye qq chose
:calim2:

Voici mon pb, j'importe des données dans mon classeur et je voudrais éviter d'importer en doublons. J'ai donc laissé l'importation se faire et une fois faite alors je filtre mon en-tête via la date et s'il y a deux lignes pour une même date alors il faut effacer la dernière ligne.

Voici le code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Dim Date_visite As String Range("B6553").End(xlUp).Select = Date_visite 'permet normalement de connaître la date de ligne importée Range("B5").Select Selection.AutoFilter Field:=1, Criteria1:=Date_visite 'je filtre le tableau avec la datre de la dernière importation ActiveCell.Offset(2, 0).Select 'je descend de 2 lignes valeur = ActiveCell.Value If Not IsEmpty(valeur) Then 'il y a une donnée sur la 2ième ligne donc la ligne importée est en doublons ActiveRow.Select 'selection de la ligne doublons Selection.Delete Shift:=xlUp ' suppression de la ligne doublons Range("B5").Select Else 'il n'y a pas de donnée sur la 2ième ligne donc pas de doublons End If
Il me mets objet requis sur

Code:

Range("B6553").End(xlUp).Select = Date_visite

QQ 1 peut-il m'orienter ?

Merci par avance

13/05/2009, 16h40
DeaD78

Bonjour,

Remplace

Code:

Range("B6553").End(xlUp).Select

par

Code:

Range("B6553").End(xlUp).Value

Je viens de faire le test, ça marche.

Allez, en selle (de cheval) pour la suite :king:

EDIT : Ah, ça marche mais de travers, il te sort encore l'objet requis parfois. Attends, je vais avoir quelque chose de mieux pour toi, je le retrouve et je le poste.

Je mets ça dans un nouveau post histoire que ça ne soit pas trop fouilli.

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
Sub test()
 
Dim FL1 As Worksheet
Dim Valeur As Variant, c As Range
Dim NoLigne As Long, DerLig As Long
    Set FL1 = Worksheets("NomDeTaFeuille")
    NoLigne = 1 'Si les données commencent à la ligne 1
    Do
        If Not Cells(NoLigne, 2) = "" Then 'Colonne B
            Valeur = Cells(NoLigne, 2)
            Do
                With FL1.Range("B" & NoLigne + 1, [B65536].End(xlUp))
                    DerLig = 0
                    Set c = .Find(Valeur, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        If c.Row > NoLigne Then
                            DerLig = c.Row
                            c.EntireRow.Delete
                        End If
                    End If
                    Set c = Nothing
                End With
            Loop While DerLig > NoLigne
        End If
        NoLigne = NoLigne + 1
    Loop While NoLigne < FL1.Range("B65536").End(xlUp).Row
 
End Sub

Voilà, ce code te vire les doublons colonne B. De plus, il est optimisé. Après, libre à toi de rajouter un filtre sur ta colonne.

Bonne chance !

Bonjour à tous et à Dead78,

Parfait ce code de la mort !!!! :yaisse2:

Tu es parfait :king:

Voici le code pour ceux qui veulent s'en inspirer.
Le principe est d'aller chercher des données précises dans des fichiers contenant un code client précis. S'il y a un fichier qui contient ce code client alors on récupére certaines données de la ligne ayant le code client et on les copie dans le fichier source.
La 2nd macro évite de copier des lignes déjà importées.

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
90
91
92
93
94
95
96
Public Sub Importe_Visite()
 
Dim CodeClient As String
 
CodeClient = Worksheets("Fiche client").Range("E3")
 
Const LookInFolder = "C:\Bordereau de visites\"
 Dim xlFichier As String 'fichier xls trouvé
 Dim ActionLigne As Long 'Ligne où doivent être copiées les données trouvées
 Dim xlClasseur As Workbook 'Classeur de recherche
 Dim xlFeuillet As Worksheet 'Feuillet de recherche
 Dim xlRange As Range  'Plage où le code client a été trouvé
 
 'Rechercher les fichiers xls du dossier
 xlFichier = Dir(LookInFolder & "*.xls")
 Do While xlFichier <> ""
'Ouvrir le classeur du fichier trouvé
   Set xlClasseur = Workbooks.Open(Filename:=LookInFolder & xlFichier, ReadOnly:=True)
'Pour chaque Feuillet du classeur
   For Each xlFeuillet In xlClasseur.Worksheets
'Récupérer la plage où CodeClient est trouvé
     Set xlRange = xlFeuillet.Range("A1:A65536").Find(CodeClient, , xlValues, xlWhole, xlByRows, xlNext, False, False)
'Si CodeClient a été trouvé alors récupéré les valeurs
    If Not xlRange Is Nothing Then
       With ThisWorkbook.Worksheets("Actions")
 
 
 
         ActionLigne = .Range("B65535").End(xlUp).Row + 1
         .Cells(ActionLigne, 2) = xlFeuillet.Range("G5")
         .Cells(ActionLigne, 3) = xlFeuillet.Cells(xlRange.Row, 2)
         .Cells(ActionLigne, 4) = xlFeuillet.Cells(xlRange.Row, 7)
         .Cells(ActionLigne, 5) = xlFeuillet.Cells(xlRange.Row, 8)
         .Cells(ActionLigne, 6) = xlFeuillet.Cells(xlRange.Row, 9)
         .Cells(ActionLigne, 7) = xlFeuillet.Cells(xlRange.Row, 10)
 
 
 
 
 
       End With
       Set xlRange = Nothing
    End If
   Next
   Set xlFeuillet = Nothing
   xlClasseur.Close
   Set xlClasseur = Nothing
   xlFichier = Dir
 
 
 
   verif_importation
 
 Loop
 
     'trier par date de visite
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("B6"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
 
End Sub
 
 
 
 
Sub verif_importation()
 
Dim FL1 As Worksheet
Dim Valeur As Variant, c As Range
Dim NoLigne As Long, DerLig As Long
    Set FL1 = Worksheets("Actions")
    NoLigne = 6 'Si les données commencent à la ligne 1
    Do
        If Not Cells(NoLigne, 2) = "" Then 'Colonne B
            Valeur = Cells(NoLigne, 2)
            Do
                With FL1.Range("B" & NoLigne + 1, [B65536].End(xlUp))
                    DerLig = 0
                    Set c = .Find(Valeur, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        If c.Row > NoLigne Then
                            DerLig = c.Row
                            c.EntireRow.Delete
                        End If
                    End If
                    Set c = Nothing
                End With
            Loop While DerLig > NoLigne
        End If
        NoLigne = NoLigne + 1
    Loop While NoLigne < FL1.Range("B65536").End(xlUp).Row
 
End Sub

Encore merci pour ceux qui m'ont aidés.

Nini moins à poil