İki ayrı sayfadaki Rakam listesini tek liste halinde 3 cu sayfaya yazdirmak

[adslboy]

Selamlar,

Arkadaşlar ekteki dosyamda anlatmaya çalıştım.

indirip yardimci olucak Degerli Arkadaslara

simdiden tesekurler

Saygılar

 

[Orion1]

Dosyanız ekte.

Sub karsilastir()
Dim i As Long, k As Integer, sat As Long
Dim deg1 As String, deg2 As String, j As Long
Sheets("Sayfa3").Select
Range("A1:P65536").ClearContents
sat = 1
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
For i = 1 To s1.Cells(65536, "A").End(xlUp).Row
deg1 = ""
    For k = 1 To 15
        deg1 = deg1 & "-" & Trim(s1.Cells(i, k).Value)
    Next k
    deg1 = Right(deg1, Len(deg1) - 1)
    For j = 1 To s2.Cells(65536, "A").End(xlUp).Row
    deg2 = ""
        For k = 1 To 15
            deg2 = deg2 & "-" & Trim(s2.Cells(j, k).Value)
        Next k
        deg2 = Right(deg2, Len(deg2) - 1)
        If deg1 = deg2 Then
        deg = Split(deg1, "-")
        GoTo atla1
    End If
    Next j
GoTo atla2
atla1:
    For k = LBound(deg) To UBound(deg)
        Cells(sat, k + 1).Value = deg(k)
        Cells(sat, "P").Value = i
    Next k
     sat = sat + 1
atla2:
Next i
MsgBox "İşlem tamamlanmıştır"
End Sub

 

[adslboy]

Sayin Evren Gizlen,

Sizlere cok teşekur ederim, emeginize sağlık.

Sizden Rica etsem bide bunu su sekilde yapmak mumkunmudur !


Sayfa 1 her satırı karşılastırıp ayni olan satirlarin tespit edilip

otomatikmen sayfa 1 den silinmesi ve sayfa 2 ye silinen satirlardaki rakamlarin yazdirilmasi.

ayrıca ılk dosyaya Karşılaştır butonunun altına tum sayfadakı verileri silicek bir Temizle butonu eklemek mumkunmudur

Saygılarımla

 

[Orion1]

Sayin Evren Gizlen,

Sizlere cok teşekur ederim, emeginize sağlık.

Sizden Rica etsem bide bunu su sekilde yapmak mumkunmudur !


Sayfa 1 her satırı karşılastırıp ayni olan satirlarin tespit edilip

otomatikmen sayfa 1 den silinmesi ve sayfa 2 ye silinen satirlardaki rakamlarin yazdirilmasi.

ayrıca ılk dosyaya Karşılaştır butonunun altına tum sayfadakı verileri silicek bir Temizle butonu eklemek mumkunmudur

Saygılarımla

Bunu dahada açıklamnız gerekli.
Sayfa1de mükererr kayıtlar tek durumunamı inecek yosa sayfa2 ile karşılaitııp ayni isemi silinecekçDurum belirsiz.
Sorunuzun çözüme ulaşabilmesi için daha fazla ve detaylı açıklama yapmanız gereklidiri.
Aksi takdirde ne yapılacağını bilemeyiz.

 

[adslboy]

Sayın Evren Gizlen,

Örnek dosyayı ekliyorum!

Saygılar

 

[Orion1]

Dosyanız ekte.

Sub mukerrer()
Dim i As Long, z As Object, deg As String, k As Byte
Dim deg1() As String, sat As Long, sat2 As Long
sat = 1
sat2 = 1
Sheets("Sayfa1").Select
Sheets("Sayfa2").Range("A:O").ClearContents
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To Cells(65536, "A").End(xlUp).Row
deg = ""
    For k = 1 To 15
        deg = deg & "-" & Cells(i, k).Value
    Next k
    deg = Right(deg, Len(deg) - 1)
    If Not z.exists(deg) Then
        z.Add (deg), 1
        Else
        z.Item(deg) = z.Item(deg) + 1
    End If
Next i
Range("A:O").ClearContents
For Each vkey In z.keys
    deg1 = Split(vkey, "-")
    If z.Item(vkey) > 1 Then
        For k = LBound(deg1) To UBound(deg1)
            Sheets("Sayfa2").Cells(sat, k + 1).Value = deg1(k)
        Next k
        sat = sat + 1
    End If
    For k = LBound(deg1) To UBound(deg1)
        Sheets("Sayfa1").Cells(sat2, k + 1).Value = deg1(k)
    Next k
    sat2 = sat2 + 1
Next
MsgBox "İşem tamam"
End Sub

 

[adslboy]

Hocam en başta emeginize ve ilginize teşekur etmek isterim

Tam istedigim gibi olmus

Saygılarla..

 

[Orion1]

Hocam en başta emeginize ve ilginize teşekur etmek isterim

Tam istedigim gibi olmus

yalniz bazen Sayfayi sil dedigimde sub hatası verıyor ve kod o noktada duruyor

Tekrar bir gozden gecirirseniz sevinirim

Saygılarla..

Düzeltmeyi yaptım.
6 numaralı mesajdan indirebilirsiniz.

 

[adslboy]

Düzeltmeyi yaptım.
6 numaralı mesajdan indirebilirsiniz.

Soylenecek kelime yok ..:bravo:

 

[Orion1]

Son yaptığım düzenleme ie Sayfa2'de P sütununda mükerrer kayıtların adedinide yazıyor.
Dosya ekte.

 

[ExceI]

çoooook teşekürler.

 

[Orion1]

çoooook teşekürler.

Rica ederim.
İyi çalışmalar.