veri listeleme

[erkandeveci]

Şöyle bişey yapmak istiyorum A2 hücresinde data validation ile seçim yaptığımda Sheet 2 de ki illere göre verileri getirebilriyorum forum yardımı ile teşekkür ederim ama şöyle bişey yapabilirmiyiz Toplam değeri sıfır olanları ya da değeri olmayanları listeye getirmesin sadece toplam sütunundaki olan değerleri getirsin.
şimdiden herkesin bayramını en içten dileklerimle kutluyorum teşekkür ederim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları ilgili sayfanın (S1) kod bölümüne kopyalayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [A2]) Is Nothing Or Target.Value = "" Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim s2  As Worksheet, _
        Kol As Integer, _
        i   As Long, _
        j   As Long, _
        c   As Range
    Set s2 = Sheets("S2")
    
    Set c = s2.Range("1:1").Find(Target.Value, LookIn:=xlValues)
    If Not c Is Nothing Then
        Kol = c.Column
    Else
        MsgBox Target.Value & " ADLI MERKEZ BULUNAMADI"
        Exit Sub
    End If
    
    i = Cells(Rows.Count, "A").End(3).Row
    
    If i > 4 Then Range("A5:D" & i).ClearContents
    
    i = 4
    
    For j = 3 To s2.Cells(Rows.Count, "A").End(3).Row - 1
        If s2.Cells(j, Kol) > 0 Then
            i = i + 1
            Cells(i, "A") = s2.Cells(j, "A")
            Cells(i, "B") = s2.Cells(j, Kol)
            Cells(i, "C") = s2.Cells(j, Kol + 1)
            Cells(i, "D") = s2.Cells(j, Kol + 2)
        End If
    Next j
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    MsgBox i - 4 & " Adet Kayıt Aktarılmıştır....", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[erkandeveci]

çok teşekkür ederim ellerinize sağlık, buna birde büykükten küçüğe doğru sırlamayı ekleyebilirmiyz..

 

[Necdet]

çok teşekkür ederim ellerinize sağlık, buna birde büykükten küçüğe doğru sırlamayı ekleyebilirmiyz..

Merhaba,

Kodları aşağıdaki kodlar ile değiştiriniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [A2]) Is Nothing Or Target.Value = "" Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim s2  As Worksheet, _
        Kol As Integer, _
        i   As Long, _
        j   As Long, _
        c   As Range
    Set s2 = Sheets("S2")
    
    Set c = s2.Range("1:1").Find(Target.Value, LookIn:=xlValues)
    If Not c Is Nothing Then
        Kol = c.Column
    Else
        MsgBox Target.Value & " ADLI MERKEZ BULUNAMADI"
        Exit Sub
    End If
    
    i = Cells(Rows.Count, "A").End(3).Row
    
    If i > 4 Then Range("A5:D" & i).ClearContents
    
    i = 4
    
    For j = 3 To s2.Cells(Rows.Count, "A").End(3).Row - 1
        If s2.Cells(j, Kol) > 0 Then
            i = i + 1
            Cells(i, "A") = s2.Cells(j, "A")
            Cells(i, "B") = s2.Cells(j, Kol)
            Cells(i, "C") = s2.Cells(j, Kol + 1)
            Cells(i, "D") = s2.Cells(j, Kol + 2)
        End If
    Next j
    
    'B sütununa göre büyükten küçüğe sıralar
    Range("A5:D" & i).Sort Key1:=[B1], order1:=xlDescending
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    MsgBox i - 4 & " Adet Kayıt Aktarılmıştır....", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[erkandeveci]

çok teşekkür ederim ellerinize sağlık mutlu bayramlar

 

[erkandeveci]

birşey daha rica ede bilrmiyim bu makroyu sektör seçimi için nasıl uygulayabiliriyim.