Diğer Sekmedeki İsimleri Çağırma

[bthn35]

Merhaba,
EK'teki örnek'te Gelen_Malzeme sekmesi P5'e YASEMİN YAZDIĞIMDA TANIM_ISIMLER sekmesinin A sütununda YASEMİN İLE BAŞLAYANLARI ALIP Gelen_Malzeme Q5 hücresinden itibaren sıralamasını istiyorum. Bu mümkün mü?

 

[Ömer]

Merhaba,

Gelen_malzeme sayfasının kod bölümüne kopyalayınız. P5 hücresine değer girdiğinizde kodlar çalışır.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim S1 As Worksheet, sat As Long, c As Range, Adr As String
  
    Set S1 = Sheets("TANIM_ISIMLER")
    
    If Intersect(Target, Range("P5")) Is Nothing Then Exit Sub
    
    sat = 5
    Application.ScreenUpdating = False
    Range("Q" & sat & ":Q" & Rows.Count).ClearContents

    Set c = S1.[A:A].Find(Target & "*", , xlValues, xlWhole)
    If Not c Is Nothing Then
         Adr = c.Address
         Do
             Cells(sat, "Q") = S1.Cells(c.Row, "A")
             sat = sat + 1
             Set c = S1.[A:A].FindNext(c)
         Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    Application.ScreenUpdating = True
    
End Sub

 

[bthn35]

Oldu, çok teşekkür ederim

 

[bthn35]

Merhaba,

Gelen_malzeme sayfasının kod bölümüne kopyalayınız. P5 hücresine değer girdiğinizde kodlar çalışır.

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim S1 As Worksheet, sat As Long, c As Range, Adr As String
 
    Set S1 = Sheets("TANIM_ISIMLER")
   
    If Intersect(Target, Range("P5")) Is Nothing Then Exit Sub
   
    sat = 5
    Application.ScreenUpdating = False
    Range("Q" & sat & ":Q" & Rows.Count).ClearContents

    Set c = S1.[A:A].Find(Target & "*", , xlValues, xlWhole)
    If Not c Is Nothing Then
         Adr = c.Address
         Do
             Cells(sat, "Q") = S1.Cells(c.Row, "A")
             sat = sat + 1
             Set c = S1.[A:A].FindNext(c)
         Loop While Not c Is Nothing And c.Address <> Adr
    End If
   
    Application.ScreenUpdating = True
   
End Sub

Merhaba Tekrar,
Birşey daha sormak istiyorum eğer mümkünse. Bu işlemi birden fazla sekmeye yapmaya başladım ancak hepsinin yan sütununda yer olmayabiliyor. Textbox gibi bir yerde ismi aratıp altında çıkan isimlere çift tıklayınca en son hücredeki yere yapıştırabilir şeklinde olabiliyor mu? Böylece her sekme için ayrı ayrı kod yapıştırıp çoğaltmama gerek kalmaz

 

[Ömer]

Söylediğinizi anlayamadım.
TANIM_ISIMLER sayfası gibi birden fazla sayfa var arama yaparken bu sayfalarda da mı aramaya yapacak.

 

[bthn35]

Pardon ben anlatamadım galiba. Bu yaptığınız işlemi textbox'ta arama yapacak şekilde değiştirebilir miyiz? Aranacak ismi textbox'a yazacağım ve gelen sonuçlardan ismi seçeceğim

 

[Ömer]

Bu tamamen farklı bir konu, forumda örnekleri mevcut. Arama yaptıktan sonra istediğiniz sonuca ulaşamazsanız yeni konu açarak sorunuzu detaylı açıklamanızı rica ederim.

 

[bthn35]

O zaman son bir soru daha sorabilir miyim? Bu yaptığınız kod'da P5 hücresi boş olduğunda bütün isimleri getiriyor, boş olduğundan hiçbir işlem yapmaması için ne eklemem gerekiyor?

 

[Ömer]

If Intersect(Target, Range("P5")) Is Nothing Then Exit Sub

satırından sonra aşağıdaki satırı ilave ediniz.

If Target = "" Then Exit Sub

 

[Ömer]

İlave olarak başlık satırı dahil olmaması için kodların güncel hali aşağıdaki gibi olması daha doğru olacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim S1 As Worksheet, sat As Long, c As Range, Adr As String, son As Long
 
    Set S1 = Sheets("TANIM_ISIMLER")
    
    If Intersect(Target, Range("P5")) Is Nothing Then Exit Sub
    
    If Target = "" Then Exit Sub
    
    son = S1.Cells(Rows.Count, "A").End(xlUp).Row
    
    sat = 5
    Application.ScreenUpdating = False
    Range("Q" & sat & ":Q" & Rows.Count).ClearContents

    Set c = S1.Range("A2:A" & son).Find(Target & "*", , xlValues, xlWhole)
    If Not c Is Nothing Then
         Adr = c.Address
         Do
             Cells(sat, "Q") = S1.Cells(c.Row, "A")
             sat = sat + 1
             Set c = S1.Range("A2:A" & son).FindNext(c)
         Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    Application.ScreenUpdating = True
    
End Sub

 

[bthn35]

Elinize sağlık, bu şekilde güzel oldu