Hücrelerde Arama Yapmak

[gehlen]

Uğraştığım tabloda A sütununda bulunan sayıları diğer 15 sütunda bulunan sayılar ile
karşılaştırıp o sayı hangi sütunda-sütunlarda ise B sütunundaki hizasına o sütunların
1.hücrelerinde yazanı yazdırma konusunda kısıtlı zaman altında yardımlarınızı bekliyorum.
Bunu yapamazsam tek tek imkansız yetiştiremem.


İstediğimin aynısı ektedir. Excel versiyon 2007 ( Arama yapılacak sütunlarda 80.000 den fazla
sayı olan da var, 100 sayı olan da...)

 

[Ergün Güler]

Selam,
"çok acil!!" başlık kullanmadan önce forum kurallarını okuyunuz.
Başlığınızı değiştiriniz.
Örnek dosyanızı 2003 formatında yeniden güncelleyiniz.

 

[gehlen]

halen yardınlarınızı bekliyorum.

 

[meslan]

İstediğiniz bu olsa gerek.
Kodu deneyiniz.

Sub karsilastir()
[B2:B65536].Clear
For x = 2 To [A65536].End(3).Row
deg = Empty
Set bul = [C:Q].Find(Cells(x, 1), lookat:=xlWhole)
If Not bul Is Nothing Then
sut = bul.Column
Do
Set bul = [C:Q].FindNext(bul)
If deg <> Empty Then deg = deg & "  /  " & Cells(1, bul.Column)
If deg = Empty Then deg = Cells(1, bul.Column)
Loop While Not bul Is Nothing And bul.Column <> sut
End If
If deg <> Empty Then Cells(x, 2) = deg
If deg = Empty Then Cells(x, 2) = "Yok"
Next
End Sub

 

[halit3]

Uğraştığım tabloda A sütununda bulunan sayıları diğer 15 sütunda bulunan sayılar ile
karşılaştırıp o sayı hangi sütunda-sütunlarda ise B sütunundaki hizasına o sütunların
1.hücrelerinde yazanı yazdırma konusunda kısıtlı zaman altında yardımlarınızı bekliyorum.
Bunu yapamazsam tek tek imkansız yetiştiremem.


İstediğimin aynısı ektedir. Excel versiyon 2007 ( Arama yapılacak sütunlarda 80.000 den fazla
sayı olan da var, 100 sayı olan da...)

alternatif olarak kod

Sub arama()
Range("B2:B65000").ClearContents
For j = 1 To [A65536].End(3).Row
ad = Cells(j, 1).Value
son = 0
Set c = Range("c2:IV65000").Find(ad, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
son = 1
Cells(j, "B").Value = Cells(j, "B").Value & " / " & Cells(1, c.Column).Value
Set c = Range("c2:IV65000").FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
If Left(Cells(j, "B").Value, 2) = " /" Then
Cells(j, "B").Value = Mid(Cells(j, "B").Value, 4, Len(Cells(j, "B").Value))
End If
If son = 0 Then
Cells(j, "B").Value = "yok"
End If
Next
Set sh = Nothing
End Sub

 

[halit3]

kodta değişiklik yaptım.

 

[gehlen]

meslan arkadaşım çok teşekkür ederim ancak halit arkadaşımın kodlaması tam istediğim gibi.
Halit bey bu kod excel2007 de ve sütunlardan birinde 80.000 sayı olduğunda da çalışır mı?

 

[gehlen]

re

meslan arkadaşım çok teşekkür ederim ancak halit arkadaşımın kodlaması tam istediğim gibi.
Halit bey bu kod excel2007 de ve sütunlardan birinde 80.000 sayı olduğunda da çalışır mı?

 

[halit3]

meslan arkadaşım çok teşekkür ederim ancak halit arkadaşımın kodlaması tam istediğim gibi.
Halit bey bu kod excel2007 de ve sütunlardan birinde 80.000 sayı olduğunda da çalışır mı?

ben ofis 2000 kullanıyorum ama 2007 de de çalışması lazım.

 

[gehlen]

Teşekkür

alternatif olarak kod

65000 ve 65536 ların başına "1" koyunca çalıştı.

Çok teşekkür ederim, ellerinize sağlık, kurtardığınız saatler kadar ömrünüz uzasın

 

[halit3]

aslında başlık yerine bulunan değerlere ait hücrenin adresini yassa daha iyi olur

Sub arama()
Range("B2:B65000").ClearContents
For j = 1 To [A65536].End(3).Row
ad = Cells(j, 1).Value
son = 0
Set c = Range("c2:IV65536").Find(ad, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If son > 0 Then
'ekle = " / " 'burası değişebilir
ekle = " - " 'burası değişebilir
Else
ekle = ""
End If
'Cells(j, "B").Value = Cells(j, "B").Value & ekle & Cells(1, c.Column).Value 'burası değişebilir
Cells(j, "B").Value = Cells(j, "B").Value & ekle & c.Address(False, False) 'burası değişebilir
son = 1
Set c = Range("c2:IV65536").FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
If son = 0 Then
Cells(j, "B").Value = "yok"
End If
Next
Set sh = Nothing
End Sub