• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bölge Sorunu

Katılım
15 Nisan 2010
Mesajlar
15
Excel Vers. ve Dili
2003 türkçe
Elimde bir excel verisi var dünya haritası üzerinde kıtalara yaptığım satılşları içeren. Birde bu kıtalara ait ülkelerin verileri var. Üst tarafta o kıta-bölyeyi seçtiğimde aşşağısında bana o kıtaya bağlı ülkelerin litesini getirmesini istiyorum. Meslea asya seçtiğimde alt tarafta japonya-çin-malezya gibi veriler gelsin.
 
Sizce bu isteğiniz örnek dosya olmadan çözülebilir mi?
 
Acemiliğimi mazur görün altın üyelik için başvurdum da daha onaylanmadı sanırım onaylanır onaylanmaz dosyayı yükleyeceğim
 
Merhaba.

Sayfayı sağ tıklatıp Kod Görüntüle seçin.

Aşağıdaki kodu açılan sayfaya kopyalayın.

Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B2:B9")) Is Nothing Then
        Dim Say As Long
        Say = Cells(Rows.Count, "A").End(3).Row
        Range("A12:L12").AutoFilter
        Range("$A$12:$L$" & Say).AutoFilter Field:=1, Criteria1:=Target.Text
    End If
End Sub

B2 - B9 aralığında bir seçim yaptığınızda işlem gerçekleştirilecektir.
 
Aşağıdaki kodları ilgili sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırırsanız, [B2:B9] aralığında bir hücreye tıkladığınızda o hücredeki bölgeye göre filtreleme yapar:

PHP:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [B2:B9]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If Selection.Count > 1 Then Exit Sub
    son = Cells(Rows.Count, "B").End(3).Row
    Range("A12:L" & son).AutoFilter
    
    ActiveSheet.Range("$A$12:$L$" & son).AutoFilter Field:=1, Criteria1:=Target

End Sub
 
üstadım merhaba

End(3).Row "3" neyi ifade ediyor ?

Merhaba.

Sayfayı sağ tıklatıp Kod Görüntüle seçin.

Aşağıdaki kodu açılan sayfaya kopyalayın.

Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B2:B9")) Is Nothing Then
        Dim Say As Long
        Say = Cells(Rows.Count, "A").End(3).Row
        Range("A12:L12").AutoFilter
        Range("$A$12:$L$" & Say).AutoFilter Field:=1, Criteria1:=Target.Text
    End If
End Sub

B2 - B9 aralığında bir seçim yaptığınızda işlem gerçekleştirilecektir.
 
Son dolu satırın satır numarası.
 
Cells(Rows.Count, "A").End(3).Row

Rows.Count: Kaçıncı satıra kadar saymasını istiyorsak o rakamı yazmalıyız. Rows.count son satıra kadar say demektir. Son satır = 1048576 eski excel versiyonunda satır sayısı değiştiği için rakam yerine Rows.count yazıyoruz.
"A": A kolonu sayılır.
end: son
3= xlup :belirtilen hücreden yukarıya doğru ilk dolu hücre demektir.

buna göre aşağıdaki şekilde de yazılabilir.

Cells(1048576, "A").End(3).Row
Daha kısa ifade ile A sütununun 1048576 satırından başlamak üzere (xlup) yukarıya doğru bak ilk dolu hücrenin adresini ver.
 
Verdiğim kodda End sub satırından önce aşağıdaki kodları eklerseniz seçilen satırı sarı yapar:

Kod:
    [B2:L9].Interior.Color = xlNone
    Range("B" & Target.Row & ":L" & Target.Row).Interior.Color = vbYellow
 
öncelikle yusuf bey ve dalgalikur bey çok teşşekkür ederim sorunumu mükkemmel bir şekilde çözüme kavuşturduduğunuz için. Son bir sorum olacak herhangi bir boşluğa tıkladığımızda formülden çıkıp tam listeyi de göstermek için ne yapmam gerekiyor.
 
Aşağıdaki gibi deneyin. B2:B9 dışında bir yeri seçtiğinizde işlem iptal olur:

PHP:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    son = Cells(Rows.Count, "B").End(3).Row
    If Not Intersect(Target, [B2:B9]) Is Nothing Then
        If Target = "" Then Exit Sub
        If Selection.Count > 1 Then Exit Sub
        Range("A12:L" & son).AutoFilter
        
        ActiveSheet.Range("$A$12:$L$" & son).AutoFilter Field:=1, Criteria1:=Target
        [B2:L9].Interior.Color = xlNone
        Range("B" & Target.Row & ":L" & Target.Row).Interior.Color = vbYellow
    Else
        ActiveSheet.Range("$A$12:$L$" & son).AutoFilter Field:=1
        [B2:L9].Interior.Color = xlNone
        Exit Sub
    End If
End Sub
 
Şu kodları kullanın.

Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B2:B9")) Is Nothing Then
        Dim Say As Long
        Say = Cells(Rows.Count, "A").End(xlDown).Row
        Range("A12:L12").AutoFilter
        Range("$A$12:$L$" & Say).AutoFilter Field:=1, Criteria1:=Target.Text
    Else
        On Error Resume Next
        ShowAllData
    End If
End Sub
 
Son düzenleme:
üstanlar önünüzde saygıyla eğiliyorum. Tekrardan ellerinize sağlık çok teşekkür ederim.
 
merhaba dosyayı paylaşma şansınız varmı acaba teşeşkkürler
 
Geri
Üst