PDA

Tüm Versiyonu Göster : Ad ve Tarih eşleştirme..


kan-nas
31-01-2013, 12:21
Merhaba,

A ve B kolundaki isim ve tarih ile D koloundaki isim ve tarih olanları J ve k kolonuna yazdırabilir miyiz?

Excelde açıklaması var. İyi çalışmalar.

Civan Jack
31-01-2013, 12:41
Bir döngü kurup a-b ile d-e sütunlarındakiler birbirine eşitse şartıyla kopyalama yapacaksınız. Bunu siz de yapabilirsiniz Sn. kan-nas.

kan-nas
31-01-2013, 13:45
Üstad, döngü kurdum ama yapamadım. a1 kolonunda Ali ye bak d1 de varsa yaz ya da b1 kolonnunda 01-01-2013 e bak.E kolunda varsa yaz değil.Bunu ben de yaptım.
A1 kolonunda Ali B1 kolonunda 01-01-2013 varsa bunu D ve E kolounundaki aynı sıradaki Ali ve 01-01-2013 le karşılaştır varsa yaz. Örnekte A ve Bkolonundaki 2. satırdaki ali 01-01-2013 ü D ve E kolonunda 3 sırada bulunan ali ve 01-01-2013 ile eşleştirsin.
Valla yapabilseydim buraya yazmazdım.S. Civan Jack

Necdet Yeşertener
31-01-2013, 13:57
Merhaba,

Aşağıdaki kodları dener misiniz?


Sub Karsilastir()

Dim i As Long, _
j As Integer, _
c As Range, _
adr As String

Application.ScreenUpdating = False

Range("J2:K" & Rows.Count).Clear
j = 1

For i = 2 To Cells(Rows.Count, "A").End(3).Row
With Range("D:D")
Set c = .Find(Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
adr = c.Address
Do
If Cells(i, "B") = Cells(c.Row, "E") Then
j = j + 1
Cells(j, "J") = Cells(i, "A")
Cells(j, "K") = Cells(i, "B")
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> adr
End If
End With

Next i

If j = 1 Then
MsgBox "HİÇ KARŞILAŞTIRMA OLMADI....", vbCritical, "excel.web"
Else
MsgBox j - 1 & " ADET BENZER KAYIT BULUNDU....", vbInformation, "excel.web"
End If

Application.ScreenUpdating = True

End Sub

Murat OSMA
31-01-2013, 14:46
Alternatif;

Sub Karsilastir()
Dim i As Integer, a As Integer
Dim Rky As Range
a = 2: Range("J2:K" & Rows.Count).Clear
For Each Rky In Range("A2:A" & Range("A65536").End(3).Row)
For i = 2 To Range("D65536").End(3).Row
If Rky.Value = Cells(i, 4) And _
Rky.Offset(0, 1).Value = Cells(i, 5) Then
Rky.Resize(, 2).Copy Cells(a, "J")
a = a + 1
End If
Next i
Next Rky
i = Empty: a = Empty
Set Rky = Nothing
End Sub