Komple sütunda aratıp alt hücreyi kopyalatma

[bybyby]

Merhabalar,

Bir excel sayfamız var.

A ve B sütunlarımız var. A1 hücresindeki veriyi B sütununda aratıp varsa A1 ve A2 deki verileri yine alt alta B sütununa yazdırmak istiyorum. Eğer B sütununu hiç kullanmayalım derseniz C sütununa yazmakta işime gelir.

Örnek dosya ektedir.

https://dl.dropboxusercontent.com/u/8500167/karsilastirma2.xlsx

 

[ÖmerBey]

Merhaba,
Anladığım kadarıyla şöyle bir kod yazdım. Deneyiniz...

Sub kod()
For a = 1 To Range("A65500").End(3).Row
    If WorksheetFunction.CountIf(Range("B:B"), Cells(a, "A")) > 0 Then
        sat = WorksheetFunction.Match(Cells(a, "A"), Range("B:B"), 0)
        Cells(sat, "C") = Cells(sat, "B")
        Cells(sat + 1, "C") = Cells(a + 1, "A")
    End If
    sat = Empty
Next
End Sub

 

[bybyby]

Kodu çalıştırdığımda 400 uyarısı veriyor.

A sütunu 6000 satır B sütunu 50000 satır. Acaba satır sayısı sorun olabilir mi? Yoksa kodda mı hata var?

 

[ÖmerBey]

Maalesef bilmiyorum...

 

[bybyby]

Benzer bir soru daha sorulmuş ve yine siz cevaplamışsınız. Acaba o formülü benim soruma göre modifiye etmek mümkün mü?

http://www.excel.web.tr/f14/hucrelerden-veri-cekilmesi-t160091.html

 

[YUSUF44]

Sayın mucit77'nin kodunu çalıştırdığımda bende hata vermedi.

 

[bybyby]

Sanırım uzunluklarla alakalı bir sorun.

Orijinal dosyada denediğimde hata alıyorum. Dosya ektedir.

https://dl.dropboxusercontent.com/u/8500167/lang.xlsx

 

[YUSUF44]

A150 hücresinde bir formül var ve AD hatası vermiş. Onu silince 1004 "Application defined or object defined error" hatası veriyor. NEdenini çözemedim.

 

[ÖmerBey]

Örnek dosyanız için aşağıdaki kodu deneyiniz. Verileriniz çok fazla olduğu için bir müddet bilgisayarınız kitlenebilir.

Sub KOD()
DoEvents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sat As Long, a As Long
Range("C:C").Clear
Range("B:B").Copy Range("C:C")
For a = 1 To Range("A65500").End(3).Row Step 2
    If WorksheetFunction.CountIf(Range("B:B"), Cells(a, "A")) > 0 Then
        sat = WorksheetFunction.Match(Cells(a, "A"), Range("B:B"), 0)
        Cells(sat + 1, "C") = Cells(a + 1, "A")
    End If
    sat = Empty
Next
Application.ScreenUpdating = True
End Sub

 

[bybyby]

Hocam elleriniz dert görmesin. Beni büyük bir yükten kurtardınız. Son gönderdiğiniz kodlar sorunsuz çalıştı.