Sütun Karşılaştırma

[serkandurmaz]

Merhaba Arkadaşlar;
Ekli dosyada C sutunundaki numaraları B sutununda aratarak eğer aynısı var ise bulduğu yerin yanındaki satırdaki adsl nosunu D sutununda yanındaki satıra yazmasını sağlayabilirmiyiz. Ekli dosyada yapılmasını istediğim şeyi çizerek göstermeye çalıştım. Şimdiden teşekkürler...

 

[Orion1]

Dosyanızı 2003 formatında eklerseniz daha çabuk yanıt alabilirsiniz.

 

[serkandurmaz]

Ayrıca bu gönderdiğim dosya normalde sadece 100 satırdan ibaret değil, yaklaşık 7000 satırdan ibaret... Bu yüzden önemlidir..

 

[serkandurmaz]

Sütun Karşılaştırma...

Dosya 2003 formatında yeniden eklenmiştir..

 

[Orion1]

Dosyanız ektedir.

Sub aynisi_59()
Dim k As Range, sat1 As Long, sat2 As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
sat1 = Cells(65536, "B").End(xlUp).Row
sat2 = Cells(65536, "C").End(xlUp).Row
For i = 2 To sat2
    Set k = Range("B2:B" & sat1).Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then Cells(i, "D").Value = k.Offset(0, -1).Value
Next
Application.ScreenUpdating = True
MsgBox "Benzereler D sütununa çıkarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation
        
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Private Sub UserForm_Activate()
Dim satc, satb As Integer
[d2:d65000].Clear
ProgressBar1.Min = 0
ProgressBar1.Max = Cells(65536, "C").End(xlUp).Row
Application.ScreenUpdating = False
    For satc = 2 To Cells(65536, "C").End(xlUp).Row
    For satb = 2 To Cells(65536, "B").End(xlUp).Row
        If Cells(satc, "c") Like Cells(satb, "b") Then
            Cells(satc, "d") = Cells(satb, "a").Value
        End If
        DoEvents
        ProgressBar1 = satc
    Next: Next
Application.ScreenUpdating = True
    Unload Me
End Sub

 

[serkandurmaz]

Çok hızlısınız... Çok teşekkür ederim... Saygılar...

 

[Orion1]

Çok hızlısınız... Çok teşekkür ederim... Saygılar...

Rica ederim.
iyi çalışmalar.