Sayfa2'de B1 ve G1 hücrelerindeki verilere göre değerleri alt alta getirme?

[mars2]

İyi Günler;

Çalışma kitabımın 1 sayfasında listede Mahalle adları ve değerleri bulunmakta olup aynı sokakta tek çift numaralar farklı değerler almış bulunabileceği, 2. sayfa ise B1 hücresine Mahalle adını, G1 hücresine ise Sokağın veya caddenin adını yazdığımda, bu sokağa alt değerleri A7 hücresinde itibaren alt alta gelmesini istiyorum.
Her sokağın farklı değerleri de olmayıp tek değeri de olabilebeleceği

 

[hasankardas]

Sayfa2 nin kod bölümüne kopyalayıp deneyin..

Private Sub Worksheet_Change(ByVal Target As Range)
        If Intersect(Target, Range("B1,G1")) Is Nothing Then Exit Sub
    
    Dim s1 As Worksheet, s2 As Worksheet
    Dim sonSatir As Long, i As Long, sat As Long
    Dim arananMahalle As String, arananSokak As String
    Dim colMahalleKaynak As Integer, colSokakKaynak As Integer
    Dim hedefSutun As Integer, kaynakSutun As Integer
    Dim eslesmeVar As Boolean
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    On Error Resume Next
    colMahalleKaynak = s1.Rows(1).Find("Mahalle", LookAt:=xlPart).Column
    colSokakKaynak = s1.Rows(1).Find("Cadde", LookAt:=xlPart).Column
    On Error GoTo 0
    
    If colMahalleKaynak = 0 Or colSokakKaynak = 0 Then
        MsgBox "Sayfa1'de Mahalle veya Cadde/Sokak başlığı bulunamadı!", vbCritical
        Exit Sub
    End If
    
    
    arananMahalle = UCase(Replace(Replace(s2.Range("B1").Value, "i", "İ"), "ı", "I"))
    arananSokak = UCase(Replace(Replace(s2.Range("G1").Value, "i", "İ"), "ı", "I"))
    
  
    sonSatir = s2.Cells(s2.Rows.Count, 1).End(xlUp).Row
    If sonSatir >= 7 Then s2.Range("A7:Z" & sonSatir + 100).ClearContents
    
    If arananMahalle = "" Or arananSokak = "" Then Exit Sub
    
    
    sonSatir = s1.Cells(s1.Rows.Count, colMahalleKaynak).End(xlUp).Row
    sat = 7
    eslesmeVar = False
    
    Application.ScreenUpdating = False
    
    For i = 2 To sonSatir
        Dim veriMahalle As String
        Dim veriSokak As String
        
      
        veriMahalle = UCase(Replace(Replace(s1.Cells(i, colMahalleKaynak).Value, "i", "İ"), "ı", "I"))
        veriSokak = UCase(Replace(Replace(s1.Cells(i, colSokakKaynak).Value, "i", "İ"), "ı", "I"))
        
        If veriMahalle = arananMahalle And veriSokak = arananSokak Then
            eslesmeVar = True
            
            
            For hedefSutun = 1 To 15
                baslik = s2.Cells(6, hedefSutun).Value
                
                If baslik <> "" Then
                  
                    kaynakSutun = 0
                    On Error Resume Next
                    kaynakSutun = s1.Rows(1).Find(baslik, LookAt:=xlWhole).Column
                    
                    If kaynakSutun = 0 Then kaynakSutun = s1.Rows(1).Find(baslik, LookAt:=xlPart).Column
                    On Error GoTo 0
                    
                  
                    If kaynakSutun > 0 Then
                        s2.Cells(sat, hedefSutun).Value = s1.Cells(i, kaynakSutun).Value
                    End If
                End If
            Next hedefSutun
            
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    If Not eslesmeVar Then MsgBox "Aranan kriterlere uygun kayıt bulunamadı.", vbInformation, "Bilgi"
    
End Sub

 

[mars2]

Sayın hasankardas;
konu hakkında vermiş olduğunuz kodu uygulamamda sorunsuz çalıştı. yardım ve Emeğiniz için teşekkürler.
Günlerinizin iyi ve sağlıklı geçmesi dileğimle.

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak Advanced Filter yöntemide işinizi görecektir. Hem daha hızlı sonuç verecektir.

Boş bir modüle;

Option Explicit

Sub Advanced_Filter()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim rngSource As Range, rngCriteria As Range
    Dim rngOutput As Range, lastRow As Long
   
    On Error GoTo 10
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
    Set wsSource = ThisWorkbook.Worksheets("Sayfa1")
    Set wsDest = ThisWorkbook.Worksheets("Sayfa2")
   
    ' Kritere alanını temizle ve hazırla
    With wsDest
        ' Kritere başlıklarını Sayfa1'den kopyala
        .Range("M1").Value = wsSource.Range("A1").Value
        .Range("N1").Value = wsSource.Range("B1").Value
       
        ' Kritere değerlerini ata
        .Range("M2").Value = .Range("B1").Value
        .Range("N2").Value = .Range("G1").Value
        .Range("A6:H" & .Rows.Count).ClearContents
    End With
   
    ' Kaynak verileri belirle
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngSource = .Range("A1:H" & lastRow)
    End With
   
    ' Kritere ve çıktı alanlarını belirle
    Set rngCriteria = wsDest.Range("M1:N2")
    Set rngOutput = wsDest.Range("A6") ' Çıktının başlayacağı yeri değiştirebilirsiniz
   
    ' Advanced Filter uygula
    rngSource.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=rngCriteria, _
        CopyToRange:=rngOutput, _
        Unique:=False
   
10
    rngCriteria.Clear
   
    Set rngCriteria = Nothing
    Set rngOutput = Nothing
    Set rngSource = Nothing
    Set wsSource = Nothing
    Set wsDest = Nothing
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
   
    MsgBox "Filtreleme tamamlandı!"
End Sub

Aşağıdaki kodu da Sayfa2 kod bölümüne uygulayınız. B1 ve G1 hücresini güncellediğinizde kod çalışacaktır.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B1,G1")) Is Nothing Then Exit Sub
    Call Module1.Advanced_Filter
End Sub

 

[mars2]

Sayın Korhan Ayhan;

Alternatif olarak verdiğiniz kodu uyguladığımda hata vermeden çalıştı.
Konu hakkında farklı uygulama ile yardımlarınız ve emeğiniz için teşekkürler.