Discussion :

[dec3003]

bonjour a tous voila mon petit souci:
j ai crée une boucle sur la premiere feuille pour rechercher une valeur , si valeur trouvée alors copier la ligne ensuite
comme valeur trouvée boucle sur feuille 2 pour trouver la ligne sous la quelle inserer,si trouver j'insert une ligne , et je past sur la ligne insérée
ca fonctionne pour la premiere ligne de la feuille 1 mais pour les ligne suivant j ai une erreur proprieté ou methode non gérée alors qu au premier passage sur la meme ligne de code rien lol je comprend pas
si vous pouviez me preter (^^) un petit coup de mains se serait gentil merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CB_CResume_Click()
Dim dmin As Date
Dim dmax As Date
Dim typ As String 'variable de controle de contenu de cell
 
Dim lr2 As Integer ' derniere ligne remplie de la feuille destinataire
Dim y As Integer 'enumerateur ligne feuille destinataire
Dim i As Integer 'enumerateur ligne feuille source
Dim ldbr As Integer ' derniere ligne remplie feuille source
Dim a As String ' nom feuille source pour eviter faute de frappe ^^ lol
Dim b As String 'nom feuille destinataire pour eviter faute de frappe ^^ lol
Dim typ2 As String 'variable de controle de contenu de cell
b = "Resume"
a = "BDR"
dmin = Me.CB_J1.Text & "/" & Me.CB_M1.Text & "/" & Me.CB_A1.Text
dmax = Me.CB_J2.Text & "/" & Me.CB_M2.Text & "/" & Me.CB_A2.Text
ldbr = Worksheets(a).Range("A1").CurrentRegion.Rows.Count
 
lr2 = 2 ' pour etre sur de lancer le deuxieme while
i = 1
 
While i <= ldbr + 1
y = 1
    typ = Worksheets(a).Cells(i, 4).Text
                    If Worksheets(a).Cells(i, 1).Value < dmax And Worksheets(a).Cells(i, 1).Value > dmin Then
                       Worksheets(a).Rows(i).Copy
                    End If
                    While y < lr2 + 1
 
                    lr2 = Worksheets(b).Range("A1").CurrentRegion.Rows.Count
 
                    typ2 = Worksheets(b).Cells(y, 1).Text
 
                        If Worksheets(b).Cells(y, 1).Text = typ Then
                        Worksheets(b).Rows(y + 1).Select
                        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
                        Worksheets(b).Cells(y, 1).Paste
 
 
                        End If
                        y = y + 1
                    Wend
                    i = i + 1
Wend
End Sub

comme vous pouver le remarquer j ai introduit une variable pour la derniere ligne de chaque feuille car si je dois mettre un nombre genre 32000 pour verifier chaque ligne j ai le ventillo s'affole (il prepare un decollage pour mars lol)

[Qwazerty]

SAlut

Lorsque l'on crée une boucle en vu de la suppression de ligne, il est obligatoire de commencer par le bas du tableau pour ne pas modifier la position des cellules qui seront pointées dans la suite de la boucle.
Très simple a appréhender, imagines 10 cellules les unes en dessous des autres, tu boucles de la ligne 1 a 10, arrivé à la 3eme tu la supprimes, mais ta boucle elle continue sur sa lancé et au tour suivant pointe sur la ligne 4 ... hors dans la ligne 3 tu ne test pas son nouveau contenu ...

Pour les dates il est préférable d'utiliser dateserial afin de générer une date valide, de plus par la suite lorsque tu veux comparer le contenu d'une cellule contenant une date, il est préférable d'utiliser Value2 plutôt que value, en effet Value2 ne tient pas compte du formatage de ta cellule, si tu as choisi de n'afficher que le moi et l'année, value2 aura le contenu complet sous format date (un réel quoi) et pas une chaine "01-janv" par exemple.

Dernière remarque sur ton code, tu initialises la variable Lr2 au début de ton code, tu te retrouves obligé de faire cela car cette ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

lr2 = Worksheets(b).Range("A1").CurrentRegion.Rows.Count

est mal placée, en effet elle devrait se trouver avant le début de ta boucle.... ha je me rend compte en tapant ça que c'est peut être bien moi qui fait erreur en interprétant mal ce que tu souhaitais faire, je m'arrête la et te pose la question suivante.
La ligne prise dans la feuille source, peut-elle avoir besoin d'être inséré a plusieurs endroit dans la feuille destination ? ou n'a t elle qu'une seule place?
En fonction de ta réponse je finirai mon explication ou modifierai mon code en conséquence.

Voici le code que j'utiliserais

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Cb_CRes()
Dim Sht_Source As Worksheet, Sht_Dest As Worksheet
Dim dmin As Date, dmax As Date
Dim Cell_Test As Range, Cell_Find As Range
 
'Initialisation de variables
Set Sht_Source = Sheets("Resume")
Set Sht_Dest = Sheets("BDR")
dmin = DateSerial(CInt(CB_A1.Text), CInt(CB_M1.Text), CInt(CB_J1.Text))
dmax = DateSerial(CInt(CB_A2.Text), CInt(CB_M2.Text), CInt(CB_J2.Text))
 
'on boucle sur toutes les cellule de la colonne D (de 4 a la derniere non vide)
For Each Cell_Test In Sht_Source.Range(Sht_Source.Cells(Rows.Count, "D"), "D4") 'on commence ici par le bas du tableau, toujours pratiquer ainsi quand il faut par la suite supprimer des lignes
    With Cell_Test.Offset(0, -3)
        'On test la cellule contenant la date
        If .Value2 < dmax And .Value > dmin Then
            'La date corespond aux criteres
            'On recherche ou l'on va placer cette ligne dans la feuille de destination
            Set Cell_Find = Sht_Dest.Range("A1", Sht_Dest.Cells(Rows.Count, "A")).Find(Cell_Test.Value2, LookIn:=xlValues)
            'On regarde si une ligne correspondante a été trouvée
            If Not Cell_Find Is Nothing Then
                'c'est le cas ici, on coupe et on insert la nouvelle ligne
                Cell_Test.EntireRow.Cut
                Cell_Find.Offset(1, 0).EntireRow.Insert
            Else
                'Ici pas de correspondance trouver
                'Mettre un code éventuel selon tes besoins
            End If
        End If
    End With
Next
End Sub

L'utilisation des boucle for each Next permet d'avoir un code moins lourd est plus digest. A toi de voir.

A++
Qwaz

[dec3003]

bonjour a tous sur le temps d'avoir une reponse j ai reflechi a la question et j ai remplacer par ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CB_CResume_Click()
Dim dmin As Date
Dim dmax As Date
Dim typ As String 'variable de controle de contenu de cell
 
Dim lr2 As Integer ' derniere ligne remplie de la feuille destinataire
Dim y As Integer 'enumerateur ligne feuille destinataire
Dim i As Integer 'enumerateur ligne feuille source
Dim ldbr As Integer ' derniere ligne remplie feuille source
Dim a As String ' nom feuille source pour eviter faute de frappe ^^ lol
Dim b As String 'nom feuille destinataire pour eviter faute de frappe ^^ lol
Dim typ2 As String 'variable de controle de contenu de cell
b = "Resume"
a = "BDR"
dmin = Me.CB_J1.Text & "/" & Me.CB_M1.Text & "/" & Me.CB_A1.Text
dmax = Me.CB_J2.Text & "/" & Me.CB_M2.Text & "/" & Me.CB_A2.Text
ldbr = Worksheets(a).Range("A1").CurrentRegion.Rows.Count
 
lr2 = 2 ' pour etre sur de lancer le deuxieme while
i = 1
 
While i <= ldbr + 1
y = 1
    typ = Worksheets(a).Cells(i, 4).Text
                    If Worksheets(a).Cells(i, 1).Value <= dmax And Worksheets(a).Cells(i, 1).Value >= dmin Then
 
 
                    While y < lr2 + 1
 
                    lr2 = Worksheets(b).Range("A1").CurrentRegion.Rows.Count
 
                    typ2 = Worksheets(b).Cells(y, 1).Text
 
                        If Worksheets(b).Cells(y, 1).Text = typ Then
                        Worksheets(b).Rows(y + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Worksheets(b).Cells(y + 1, 1).Value = Worksheets(a).Cells(i, 1).Value
                        Worksheets(b).Cells(y + 1, 2).Value = Worksheets(a).Cells(i, 2).Value
                        Worksheets(b).Cells(y + 1, 2).Interior.ColorIndex = Worksheets(a).Cells(i, 2).Interior.ColorIndex
                        Worksheets(b).Cells(y + 1, 2).Font.ColorIndex = Worksheets(a).Cells(i, 2).Font.ColorIndex
                        Worksheets(b).Cells(y + 1, 3).Value = Worksheets(a).Cells(i, 3).Value
                        y = lr2 + 1
                        End If
                        y = y + 1
                    Wend
                    End If
                    i = i + 1
Wend
End Sub

qui marche super bien lol
j ai oublier de le notifier mais je vais faire plus attention la prochaine fois je reflechirai plusieur heure avant de poster ca m'evitera de poser des question au quel je peu trouver une solution lol

[Qwazerty]

Salut
Sans prétention aucune, tu devrais regarder au niveau performance, car le fait d'imbriquer 2 boucle sur un tableau complet me semble plutôt gourmand, ce qui te prendre peu de temps sur une 10ene de ligne par tableau, risque d'être un chouillat plus long sur des 100 de lignes, car 100 lignes sur la 1er boucle fois 100 lignes dans la 2eme boucle ... 100x100 = 10000 .... ca fait beacoup de controle pour pas grand chose et tout ceci prend du temps.
A toi de voir
A++
Qwaz