Mahalle cadde ve sokakları sorgulama listeleme

[yyhy]

Mahalle cadde ve sokakları listeleyebilir miyiz?

 

[Ömer]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, sat As Long
 
    If Intersect(Target, [H2]) Is Nothing Then Exit Sub
    Range("H6:J" & Rows.Count).ClearContents
 
    sat = 6
    With Range("E:E")
        Set c = .Find(Target, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Range("C" & c.Row & ":E" & c.Row).Copy Cells(sat, "H")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
End Sub

.

 

[sakman26]

selam,
eki inceleyiniz..
kolay gelsin..

 

[yyhy]

Sayın Sakman teşekkürler.

Sayın Sakman teşekkürler. Acaba cadde veya sokak isimlerini içerir olarak da yan tarafına eklenebilir mi? Yani içerenleri de alternatif olarak bulunabilir mi? Düzenlediğim yeni dosyayı ekledim. İyi çalışmalar.

Sayın Ömer kodu denemedim ama yeni eklediğim dosya için vermiş olduğunuz kodlaları nasıl uygulayabiliriz?

Ellerinize sağlık, teşekkürler.

 

[Ömer]

Bu şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, sat As Long
 
    If Intersect(Target, [[COLOR=red]L4[/COLOR]]) Is Nothing Then Exit Sub
    Range("[COLOR=red]L7:N[/COLOR]" & Rows.Count).ClearContents
 
    sat = [COLOR=red]7[/COLOR]
    With Range("E:E")
        Set c = .Find(Target, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Range("C" & c.Row & ":E" & c.Row).Copy Cells(sat, "[COLOR=red]L[/COLOR]")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
End Sub

 

[yyhy]

Sayın Ömer teşekkürler.

Sayın Ömer çalışma sayfasına bölge ekledim acaba arama yaparken bölgeleri de gelse daha güzel olacak yardımcı olabilir misiniz?

 

[Ömer]

Range("C" & c.Row & ":E" & c.Row).Copy

Bu satır kopyalanan aralığı ifade eder, gerisini zaten diğer mesajda işaretledim. Kendinize uyarlayabilirsiniz.

 

[yyhy]

Sayın Ömer kodları değiştiremedim,

Sayın Ömer kodları değiştiremedim, acaba dosyaya ekleme veya kodları son ekli dosyaya göre ekleyebilir misiniz?

 

[Ömer]

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, sat As Long
 
    If Intersect(Target, [M2]) Is Nothing Then Exit Sub
    Range("M5:P" & Rows.Count).ClearContents
 
    sat = 5
    With Range("E:E")
        Set c = .Find(Target, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Range("C" & c.Row & ":F" & c.Row).Copy Cells(sat, "M")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
End Sub

 

[yyhy]

Sayın Ömer kodu eklediğim dosyayı ekliyorum.

Sayın Ömer kodu eklediğim dosyayı ekliyorum, dosyada ilgili bölüm çalışmıyor, sorun nedir? Bakabilir misiniz?

 

[Ömer]

İçeren olarak değiştirmişsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, sat As Long
 
    If Intersect(Target, [M2]) Is Nothing Then Exit Sub
    Range("M5:P" & Rows.Count).ClearContents
 
    sat = 5
    With Range("E:E")
        Set c = .Find("*" & Target & "*")
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Range("C" & c.Row & ":F" & c.Row).Copy Cells(sat, "M")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
End Sub

.

 

[yyhy]

Sayın Ömer teşekkürler ihtiyaca cevap verdi.

Sayın Ömer teşekkürler ihtiyaca cevap verdi. Emeğinize sağlık.