Seri numarasına göre malzeme adını ayırma

[xlsx]

Arkadaşlar Slm,
A sütununda sicil numaraları
B sütununda da malzeme isimleri var

E1 hücresine yazacağım malzeme adını B sütununda arayıp A sütunundaki sicil numaraları ile F ve G sütununa taşımasını istiyorum.Bunu Sumproduct formülünün de bulunduğu uzun bir formül ile hallettim ama 20bin 30 bin veride kasılıyor dakikalarca bekletiyor.
Makro ile bunu yapmak mümkün mü.
Malzeme adı yanlış yazılmış olabileceği için ben sadece Kalem için "Kal" diye yazsam tüm Kal ile başlayanları verebilmeli.
Formülle ok ama kısa sürede sonuçları aktaracak koda ihtiyacım var.
not:zip olmadığı için direkt excel içinde bulunursa kodlar sevinirim.
Formülü ile yapıldığı için kod'u da daha önce eklenmiş olur diye düşündüm.Yardımınızı rica ederim.Şimdiden tşk arkadaşlar..

 

[xlsx]

Ufak bir detay

arkadaşlar malzeme adı bazen bir cümle gibi uzun kelime gruplarının içersinde yeralabiliyor. Örneğin B2 hücresinde Kalem yazan var mı diye aratırken B2de xyzqwKalemxzxq bile yazsa o Kalemi ve seri numarasını F -g Sütununa aktarabilmeli

 

[xlsx]

e3 hücresine yazdığım malzeme adını C sütununda saydırıp sonra f3de =IF(ROWS($G$3:G3)<=$E$2;INDEX($A$2:$A$6000;SMALL(IF($C$2:$C$6000=1;ROW($C$2:$C$6000)-ROW($C$2)+1);ROWS($G$3:G3)));"") formülü ile sadece benim arattırdığım malzemeyi çekebiliyorum seri numarası ile ama sadece 6000 kadar veride kasma çok fazla olmuyor.Oysa daha fazla veriye bakabilmeliyim.
kod sonrasında sonuçşarom çıktısı alınacak veri hücrelerinin yerleri hiç önemli değil.Ave B sütununa yapıştırdığımız veriyi c1de arattırdığımı F ve G hücresinde versin yeterli olur.Ama nasıl bu konuda sizlerin desteğinizi rica ediyorum

 

[ozgretmen]

Örnek dosya ekler misiniz ?

 

[xlsx]

örnek dosya ekleyemiyorum şuan, ama Ada seri numaralar B de de kelime grupları var.C1 hücresine yazdığım kelimeyi bu kelime gruplarından bulup f ve g sütununa yazdıracak bir koda ihtiyacım var arkadaşlar.

 

[xlsx]

Ya da hatırladığınız benzer kod'lar var mıdır? ÜzeRinde ben değişiklikler yapayım arkadaşlar.

 

[ozgretmen]

Ekteki örneği inceler misiniz ? Fikir vermesi bakımından...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c1]) Is Nothing Then Exit Sub
Range("B2:B100").Find(Range("C1").Text, LookIn:=xlValues).Select
k = ActiveCell.Row
m = Cells(65536, "D").End(xlUp).Row + 1
Range("A" & k & ":" & "B" & k).Select
Selection.Copy
Range("D" & m).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satır As Long, Bul As Range, Adres As String
    If Intersect(Target, [E1]) Is Nothing Then Exit Sub
    If Target <> Empty Then
    [F2:G65536].ClearContents
    Satır = 2
    Set Bul = [B:B].Find([E1], LookAt:=xlPart)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
    Do
    Cells(Satır, "F") = Cells(Bul.Row, "A")[COLOR=red].Value[/COLOR]
    Cells(Satır, "G") = Cells(Bul.Row, "B")[COLOR=red].Value[/COLOR]
    Satır = Satır + 1
    Set Bul = [B:B].FindNext(Bul)
    Loop While Not Bul Is Nothing And Bul.Address <> Adres
    Set Bul = Nothing
    End If
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
    [F2:G65536].ClearContents
    End If
End Sub

 

[xlsx]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Her 2 dosya için teşekkürler.formülle sorunsuz çalışıyordu ancak kod kadar kısa sürede yapmayacağını biliyordum.Sn Korhan sizin dosyanızda kullandığınız kod ile elimdeki diğer kodları birleştirerek sonuca ulaştı.Emekleriniz için ayrıca Tşkler tekrar.Sn. Ozgretmen dosyanızdaki kod fikir vermesi açısından inceledim size de tşk ederim.Saygılar..

 

[xlsx]

ilginç bir durum

Sn Korhan,

A ve B sütunundakileri E1'e yazdığım kelimeye göre sorunsuz aktarıyordu ancak ilginç bişi farkettim.
B sütununda örneğin B2 hücresindeki verinin uzunluğu 911 karakter olursa kodlar çalışmıyor ve aktarım olmuyor.Ancak max. 910 karakter olursa sorunsuz G sütununa aktarıyor.
911 rakamının anlamı nedir _? , farkında olmadan bişi mi bulduk

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki dosyayı güncelledim. İncelermisiniz. Kırmızı renkli kısımlar eklenmiştir.

 

[xlsx]

Tşk

Tşk, bu kısmını benim düşünmem farketmem gerekirdi, emekleriniz için teşekkürler.

 

[xlsx]

Tşk.Kodlarda yaptığım değişikliklerle birlikte kendi dosyama uyarlamam mümkün oldu.Formüle göre daha kısa zamanda sonuçlanıyor.