İçerik Ayırma

[ta2uk]

Orijinali 2000 stır olan örnek tabloda;

Sayfa2 de yer alan sayılardan biri Sayfa1 de bulunan D sütununda var ise o sayının bulunduğu satırın Sayfa3'e

Eğer yok ise Sayfa4'e taşınmasına ihtiyacım var.

Yardımcı olabilecek arkadaşlara şimdiden teşekkürler.

 

[Necdet]

Merhaba,
Bulduğunu aktaracak ta, aktarılan aynı zamanda Sayfa1 den silinecek mi?

 

[ta2uk]

Merhaba,
Bulduğunu aktaracak ta, aktarılan aynı zamanda Sayfa1 den silinecek mi?

Fark etmez, silinmese de olur...

 

[Necdet]

Merhaba,
Silinirse bulunanlar aktarılanlar, kalanlar da eşleşmeyenler olduğu için toptan sayfa4 e aktarılır.
Eğer veriler kalacaksa, o zaman kodlar daha çetrefilli hale gelir.
O yüzden sordum ki, kod yazacak arkadaşlara yardımcı olsun.

 

[ta2uk]

Merhaba,
Silinirse bulunanlar aktarılanlar, kalanlar da eşleşmeyenler olduğu için toptan sayfa4 e aktarılır.
Eğer veriler kalacaksa, o zaman kodlar daha çetrefilli hale gelir.
O yüzden sordum ki, kod yazacak arkadaşlara yardımcı olsun.

Teşekkür ederim, kalmasına gerek yok, orijinali zaten mevcut.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir deneyin, hız konusunu gerçek dosyanızda nasıl olduğunu söylerseniz fikir sahibi oluruz.
Sayfa1 deki Yeşil renk Sayfa3'e, mavi renk ise Sayfa4'e aktarıldığını belirtiyor.
Çift aktarım kontrol edilmedi, veriler silinmediği için, gerekirse o da yapılabilinir.

Public Sub Deneme()

Dim i   As Long, _
    j   As Long, _
    k   As Integer, _
    c   As Range, _
    arr As Variant
    
arr = Sayfa1.Range("A1").CurrentRegion.Value
    
For i = 2 To UBound(arr, 1)

    Set c = Sayfa2.Range("A:A").Find(arr(i, 4), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        j = Sayfa3.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For k = 1 To UBound(arr, 2)
            Sayfa3.Cells(j, k) = arr(i, k)
        Next k
        Sayfa1.Range("D" & i).Interior.Color = vbGreen
    Else
        j = Sayfa4.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For k = 1 To UBound(arr, 2)
            Sayfa4.Cells(j, k) = arr(i, k)
        Next k
        Sayfa1.Range("D" & i).Interior.Color = vbBlue
    End If

Next i

MsgBox "İşlem Bitmiştir...."

End Sub

 

[ta2uk]

Merhaba,

Aşağıdaki kodları bir deneyin, hız konusunu gerçek dosyanızda nasıl olduğunu söylerseniz fikir sahibi oluruz.
Sayfa1 deki Yeşil renk Sayfa3'e, mavi renk ise Sayfa4'e aktarıldığını belirtiyor.
Çift aktarım kontrol edilmedi, veriler silinmediği için, gerekirse o da yapılabilinir.

Public Sub Deneme()

Dim i   As Long, _
    j   As Long, _
    k   As Integer, _
    c   As Range, _
    arr As Variant
   
arr = Sayfa1.Range("A1").CurrentRegion.Value
   
For i = 2 To UBound(arr, 1)

    Set c = Sayfa2.Range("A:A").Find(arr(i, 4), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        j = Sayfa3.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For k = 1 To UBound(arr, 2)
            Sayfa3.Cells(j, k) = arr(i, k)
        Next k
        Sayfa1.Range("D" & i).Interior.Color = vbGreen
    Else
        j = Sayfa4.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For k = 1 To UBound(arr, 2)
            Sayfa4.Cells(j, k) = arr(i, k)
        Next k
        Sayfa1.Range("D" & i).Interior.Color = vbBlue
    End If

Next i

MsgBox "İşlem Bitmiştir...."

End Sub

Üstat hız konusundan işlem hızını kastediyorsanız sorun yok. Çift aktarım konusunda da Sayfa2 de yer alan aranacak değerler benzersiz(yinelenenler kaldırılmış) olduğu için sorun olmayacağını düşünüyorum. Çok teşekkür ederim emeğinize, elinize sağlık...

 

[Necdet]

Güle güle kullanınız.