XL 2010 Transfert de cellule sous condition.( résolu )

[Kael_88]

Le forum,

Problème pour moi, rigolade pour vous.

Si je clique sur un bouton, on transfère la cellule de la colonne 6 de la feuille 1 en bas de la colonne 1 de la feuille 2, si cette dernière n'est pas dans cette colonne 1 de la feuille 2 et si il y a "A" ou "D" dans la colonne 5 de la feuille 1 et ainsi de suite pour tout le tableau de la feuille 1.

Petit plus : à chaque fois qu'une cellule est ajoutée on notera " New" en colonne 6 de la feuille 2.

Cordialement

 

[vgendron]

Hello
un essai avec ce code.

Sub copie_New()

Dim tab1() As Variant

With Sheets("Feuil1")
    fin = .Range("E" & .Rows.Count).End(xlUp).Row
    tab1 = .Range("E2:G" & fin).Value
End With

With Sheets("feuil2")
    For i = LBound(tab1, 1) To UBound(tab1, 1)
        Set DejaLa = .Columns(1).Find(tab1(i, 2))
        If DejaLa Is Nothing Then
            If tab1(i, 1) = "A" Or tab1(i, 1) = "D" Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = tab1(i, 2)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = tab1(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 2) = tab1(i, 3)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 5) = "New"
            End If
        End If
    Next i
End With
End Sub

 

[Kael_88]

Le forum, @vgendron,

Merci, fonctionne correctement, mais très lent( 48 Secondes pour 1500 lignes).

y aurait il une autre façon d'aller plus vite, mon fichier original possède un peu plus de 60000 lignes.

Merci.

Cordialement

 

[vgendron]

un début de réponse avec la modif que voici

Sub copie_New()
Application.ScreenUpdating = False
Dim tab1() As Variant

With Sheets("Feuil1")
    fin = .Range("E" & .Rows.Count).End(xlUp).Row
    tab1 = .Range("E2:G" & fin).Value
End With

With Sheets("feuil2")
    For i = LBound(tab1, 1) To UBound(tab1, 1)
        Set DejaLa = .Columns(1).Find(tab1(i, 2))
        If DejaLa Is Nothing Then
            If tab1(i, 1) = "A" Or tab1(i, 1) = "D" Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = tab1(i, 2)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = tab1(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 2) = tab1(i, 3)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 5) = "New"
            End If
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[vgendron]

Question avant d'aller plus loin dans mon autre idée..
dans ta feuille 1 il ya
ligne 2: Description Article A avec qté=8
mais je le vois aussi en ligne 11 avec qté=2 puis ligne 13 avec qté 25.....
au final.. tu ne gardes QUE le premier? celui avec Qté=8 ?

 

[Kael_88]

Le forum, @vgendron,

Merci, ligne déjà ajouté, gain : 1,4 Seconde pour 1500 lignes

Dsl, pas assez vite.

non, dsl je ne garde que la cellule 6 de la feuille 1, pas les autrescellules de la ligne.


Cordialement

 

[vgendron]

Avec ceci..

Sub copie_New2()
Application.ScreenUpdating = False

Dim tab1() As Variant
Dim tab2() As Variant
Set dico2 = CreateObject("scripting.dictionary")

With Sheets("Feuil1") 'dans la feuille 1
    fin = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne sur la colonne E
    tab1 = .Range("E2:G" & fin).Value 'colonnes EFG dans un tablo vba
End With

With Sheets("feuil2") 'dans la feuille 2
    FinFeuille2 = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne sur la colonne A
    tab2 = .Range("A2:C" & FinFeuille2).Value 'colonnes ABC dans un tablo vba
       
    For i = LBound(tab2, 1) To UBound(tab2, 1) 'pour chaque ligne du tablo2 (feuille2)
        dico2.Item(tab2(i, 1)) = Array(tab2(i, 2), tab2(i, 3), "") 'on crée une clé (Colonne A) avec pour valeur un array composé de Colonne B, colonneC et colonne vide
    Next i
   
    For i = LBound(tab1, 1) To UBound(tab1, 1) 'pour chaque élément du tablo1 (feuille1)
        If Not dico2.exists(tab1(i, 2)) Then 'si la description n'est pas dans le dictionnaire
            If tab1(i, 1) = "A" Or tab1(i, 1) = "D" Then 'si c'est A ou D
                dico2.Add tab1(i, 2), Array(tab1(i, 1), tab1(i, 3), "NEW")
            End If
        End If
    Next i
       
.Range("A2").Resize(dico2.Count) = Application.Transpose(dico2.keys)
tabclé = dico2.items
.Range("B2").Resize(UBound(tabclé, 1) + 1) = Application.Index(tabclé, , 1)
.Range("C2").Resize(UBound(tabclé, 1) + 1) = Application.Index(tabclé, , 2)
.Range("F2").Resize(UBound(tabclé, 1) + 1) = Application.Index(tabclé, , 3)

End With
Application.ScreenUpdating = True
End Sub

 

[Kael_88]

Le forum, @vgendron,

Merci, 0.84 sec pour 1500 lignes, temps ok.

par contre cela me modifie toutes les valeurs des colonnes B et C de la feuille 2, c'est un problème, peut on rectifier ?

Cordialement

 

[vgendron]

Hello

par contre cela me modifie toutes les valeurs des colonnes B et C de la feuille 2,

euh.. normalement non. puisque justement. j'ai vérifié..