Soru Hücreye Girilen Veriyi Anımsamak

Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Merhabalar;
Ekli dosyamda Veri Girişi sayfasında E10:E20 hücre aralığına ,Tazminat sayfasındaki C11:C500 hücre aralığındaki verilerden herhangi birinin birkaç harfini yazdığım zaman Örneğin 2 yazdığım zaman tazminat sayfasında C11:C500 hücre aralığında içerisinde 2 olan satırları Userform1 de ListBox1 içerisine alarak ve Listbox1 e gelen verilerden istediğim satırı seçip ; Veri Girişi sayfasında E10:E20 aralığında ki hangi satırda isem o satıra ilgili veriyi yazdırma mümkün müdür?
Not: Veri girişi sayfasında E10:E20 hücresinin hangi satırına veri girersem Userform1 otomatik açılacak ve Listbox1 bulunan veriler süzülmüş halde gelecek.

 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Userformun kod bölümüne ekleyiniz. Listbox daki satıra çift tıklayınca E10:E20 aralığında aktif hücreye yazar.
Kod:
Dim S1 As Worksheet, S2 As Worksheet

Private Sub UserForm_Initialize()

    Dim i As Range, c As Range, Adr As String
  
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("TAZMİNAT")
  
    For Each i In S1.Range("E10:E20")
        If i <> "" Then
            Set c = S2.[C10:C500].Find(i.Value)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    ListBox1.AddItem c.Value
                    Set c = S2.[C10:C500].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End If
    Next i
      
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If Intersect(ActiveCell, S1.[E10:E20]) Is Nothing Then Exit Sub
    ActiveCell = ListBox1.List(ListBox1.ListIndex)
End Sub
.
 

Ekli dosyalar

Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Ömer bey çok teşekkür ederim. Kod güzel çalışıyor. Şöyle bir sıkıntı var. Veri girişi sayfasında E10:E20 hücre aralığında her hücrede farklı giriş yapacağım için farklı veri süzmesi yapması gerekirken tüm hücrelere aynı süzülmüş verileri getiriyor. Örneğin :E10 hücresine 2 yazdığım zaman 2 leri süzerek verileri getirecek .Yine farklı bir hücreye örneğin E15 hücresine Çk yazdığım zaman bu seferde Çk olanları getirecek.
Birde Veri Girişi sayfasında E10:E20 hücre aralığındaki herhangi bir hücreye veri girdiğim zaman Userform otomatik açılabilir mi?
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
E10:E20 aralığında herhangi 2 yada daha fazla hücreye veri girip formu açtığınızda tüm bu girilen değerler Listbox'a süzülmeyecek mi?
Şuan bunu yapıyor. Sizin açıklamanızı anlayamadım.
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Ömer bey E10.E20 hücre aralığına farklı seçim olacağından dolayısıyla her hücre girilen veriye göre süzülecek.
Örneğin: E10 hücresine Kn girdiğim zaman Listboxa Kn ler gelecek. Tekrar E15 hücresine Çk girdiğim zaman bu sefer Listbox Çk olanları getirecek
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Yani son girilen veriye göre süzme mi yapacak?
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Hocam birde hücreye veri girişi ve listbox gelebilir mi
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Eski kodları silip (module1 dahil) aşağıdaki kodları ilgili bölümlerine ekleyiniz.

Veri Girişi sayfası kod bölümüne:
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [E10:E20]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    deg = Target.Value
    Target.Select
    If Target <> "" Then UserForm1.Show 0
End Sub


Userform'un kod bölümüne:
Kod:
Dim S1 As Worksheet, S2 As Worksheet

Private Sub UserForm_Initialize()

    Dim c As Range, Adr As String
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("TAZMİNAT")

    Set c = S2.[C10:C500].Find(deg)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            ListBox1.AddItem c.Value
            Set c = S2.[C10:C500].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If Intersect(ActiveCell, S1.[E10:E20]) Is Nothing Then Exit Sub
    ActiveCell = ListBox1.List(ListBox1.ListIndex)
End Sub


Module1 in kod bölümüne:
Kod:
Public deg
Sub Düğme1_Tıklat()
    UserForm1.Show 0
End Sub
 

Ekli dosyalar

Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Ömer bey çok şahane olmuş .Son olarak Listboxu çift tıklayıp seçim yapınca Userformdan çıkış olabilir mi?
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
"Private Sub ListBox1_DblClick" kodlarındaki End Sub satırından önce aşağıdaki ilaveyi yapın.

Unload Me

.
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Hocam bu kodu
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [E10:E20]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    deg = Target.Value
    Target.Select
    If Target <> "" Then UserForm1.Show 0
End Sub
Bu kodun içerisine nasıl birleştirebiliriz?

Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    Sheets("VERİ GİRİŞİ").Unprotect 1978
    
    Dim Veri As Range, Bul As Range
    
    If Not Intersect(Target, Range("D9")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("D9"))
            If Veri.Value <> "" Then
                Set Bul = Sheets("KADASTROBİLGİLERİ").Range("F:F").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Range("D16").Value = Bul.Offset(, 2).Value
                Else
                    
                End If
            Else
                Range("D16").Value = ""
            End If
        Next
    ElseIf Not Intersect(Target, Range("D19")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("D19"))
            If Veri.Value <> "" Then
                Set Bul = Sheets("KADASTROBİLGİLERİ").Range("F:F").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Range("D27").Value = Bul.Offset(, 2).Value
                    Range("D31").Value = Bul.Offset(, 1).Value
                Else
                  
                End If
            Else
                Range("D27").Value = ""
                Range("D31").Value = ""
            End If
        Next
    End If
Sheets("VERİ GİRİŞİ").Protect 1978
End Sub
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Deneyiniz.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)

    Sheets("VERİ GİRİŞİ").Unprotect 1978
    
    Dim Veri As Range, Bul As Range
    
    If Not Intersect(Target, [E10:E20]) Is Nothing Then
        [E10:E20].Locked = False
        [E10:E20].FormulaHidden = False
        If Target.Count = 1 Then
            deg = Target.Value
            Target.Select
            If Target <> "" Then UserForm1.Show 0
        End If
    End If
    
    If Not Intersect(Target, Range("D9")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("D9"))
            If Veri.Value <> "" Then
                Set Bul = Sheets("KADASTROBİLGİLERİ").Range("F:F").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Range("D16").Value = Bul.Offset(, 2).Value
                Else
                    
                End If
            Else
                Range("D16").Value = ""
            End If
        Next
    ElseIf Not Intersect(Target, Range("D19")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("D19"))
            If Veri.Value <> "" Then
                Set Bul = Sheets("KADASTROBİLGİLERİ").Range("F:F").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Range("D27").Value = Bul.Offset(, 2).Value
                    Range("D31").Value = Bul.Offset(, 1).Value
                Else
                  
                End If
            Else
                Range("D27").Value = ""
                Range("D31").Value = ""
            End If
        Next
    End If
    
    Sheets("VERİ GİRİŞİ").Protect 1978
    
End Sub
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Hocam asıl dosyama uyarladım. Fakat veri girişi sayfasında şu kodda hata verdi.

Kod:
[I18:I25].Locked = False
 
Moderatör tarafında düzenlendi:
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Hocam hücre birleştirilmiş olduğundan hata veriyor.
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Birleştirilmiş hücre kullandığınız için.

[I18:I25] yerine [I18:N25] yazarak deneyiniz. 3 farklı yeri de bu şekilde değiştiriniz.

Not: Verileriniz gerçek veri olduğunu düşünerek eklediğiniz son dosyayı kaldırdım.

Bu arada Samsun'a selamlar. Üniversitede beş yıl öğrenciliğimde çok güzel günlerim ve hala devam eden dostluklarım oldu.
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Aleyküm selam hocam. Hocam makro hata vermiyor. Userform açılıyor. Fakat Listboxa veri bazen gelmiyor. Dosyadan çıkış yaptığım zaman tekrar girince oluyor. Birde Listboxtan seçim yapıp; diğer satırda arama yapınca veriler gelmiyor
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Veri girişi sayfası [I18:I25] aralığından mı bahsediyorsunuz. Ben doğrulamadan her seçim yaptığımda userform açılıyor ve seçim yapabiliyorum.
Ayrıca diğer satırdan kastınız nedir?
 
Katılım
7 Şubat 2021
Mesajlar
434
Excel Vers. ve Dili
2010, Türkiye
Hocam I18 hücresine veri girip Listboxtan ilgili veriyi seçtikten sonra bir alt satırda tekrar veri girip enter tuşuna basılınca listbox veri gelmiyor
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Veri girişi kodlarındaki ilgili bölümü aşağıdaki gibi değiştirin. Module13.Düğme1_Tıklat
Kod:
    If Not Intersect(Target, [I18:N25]) Is Nothing Then
        [I18:N25].Locked = False
        [I18:N25].FormulaHidden = False
        If Target.Count = 1 Then
            deg = Target.Value
            Target.Select
            If Target <> "" Then Module13.Düğme1_Tıklat
        End If
    End If
 
Üst