Hücre Değerine Göre Süzme

[bekir38]

merhaba arkadaşlar,,,

aşağıdaki konu ile bağlantılı ama biraz değişik bir konu,,

http://www.excel.web.tr/f48/makine-sicil-karty-t141013.html

hücre değeri her değiştiğinde otomatik çalışan ve değere göre süzme yapan bir makro lazım,

ekteki örnekte bir tane makro çalıştırdım ama hücre değeri her değiştiğinde yeni bir makro yazmak yerine bunun otomatik olanı varmıdır diye sormak istedim,,,

siteye biraz göz attım bulamadım, varsa öneriniz veya benzer çalışmalar paylaşırsanız sevinirim,,,

teşekkürler,,,

 

[Korhan Ayhan]

RAPOR isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

C4 hücresine değer girip sonucu gözlemleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, Kriter As Variant, Son As Long
    
    If Intersect(Target, Range("C4")) Is Nothing Then Exit Sub
    
    Set S1 = Sheets("Rapor")
    Set S2 = Sheets("2014 YILI")
    
    S1.Range("A13:J" & Rows.Count).ClearContents
    
    Kriter = Target
    
    S2.Range("A1").AutoFilter 1, Kriter
    Son = S2.Cells(Rows.Count, 1).End(3).Row
    If Son > 1 Then
    S2.Range("A2:I" & Son).Copy
    S1.Range("B13").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Target.Select
    Son = S1.Cells(Rows.Count, 2).End(3).Row
    S1.Range("A13") = 1
    S1.Range("A13:A" & Son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[bekir38]

RAPOR isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

C4 hücresine değer girip sonucu gözlemleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, Kriter As Variant, Son As Long
    
    If Intersect(Target, Range("C4")) Is Nothing Then Exit Sub
    
    Set S1 = Sheets("Rapor")
    Set S2 = Sheets("2014 YILI")
    
    S1.Range("A13:J" & Rows.Count).ClearContents
    
    Kriter = Target
    
    S2.Range("A1").AutoFilter 1, Kriter
    Son = S2.Cells(Rows.Count, 1).End(3).Row
    If Son > 1 Then
    S2.Range("A2:I" & Son).Copy
    S1.Range("B13").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Target.Select
    Son = S1.Cells(Rows.Count, 2).End(3).Row
    S1.Range("A13") = 1
    S1.Range("A13:A" & Son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

çok teşekkürler üstad, gayet güzel çalışıyor,,,

 

[bekir38]

şimdi de resim göstermiyor,,,,
sorun ne bulamadım ama daha önce bu kod çalışıyordu,,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim resim As Range
On Error Resume Next
If Target.Address = "$C$4" And Target.Value <> 0 Then
For Each resim In Range("M1:M45")
If Range("C4").Value = resim.Value Then
Image1.Picture = LoadPicture("C:\Bakım\" & resim.Offset(0, 1))
End If
Next resim
End If
End Sub

bir bakarmısınız arkadaşlar?

 

[ZorBey_]

Merhaba Sayın bekir38
iyi çalışmalar
Ekli dosyayı denermisiniz.

 

[bekir38]

Merhaba Sayın bekir38
iyi çalışmalar
Ekli dosyayı denermisiniz.

Emek için teşekkürler,,,

hata veriyor ama sebebini çözemedim,,,

CommandButton1_Click

sanırım peşinden gelen makroyu çalıştıramıyor?
yanlış birşeymi yapıyorum yoksa?

 

[ZorBey_]

Private Sub CommandButton11_Click()
11 yazılı Onu 1 Yapın Lütfen
Veya dosyayı tekrar indirin

 

[bekir38]

Private Sub CommandButton11_Click()
11 yazılı Onu 1 Yapın Lütfen
Veya dosyayı tekrar indirin

tamamdır sn. Zorbey , çok teşekkürler,,,

 

[ZorBey_]

Kolay gelsin iyi çalışmalar.

 

[bekir38]

arkadaşlar basit bir program oldu, ama işimizi görecek şekilde,
emeği geçen herkese teşekkürler,,,

buraya ekleyeyim, belki birilerine de lazım olur,

açıklama ; resimleri c:bakım klasörü altında olmasını sağlayınız,,

aşağıdaki konununda çözümü olmuş oldu,

http://www.excel.web.tr/f48/makine-sicil-karty-t141013.html

çok ama çok teşekkürler excel.web.tr

 

[bekir38]

üstteki çalışmaya ana sayfa ekledim,
sayfalar arası geçiş, makrolarla olsun istediler, onu düzenledim,,
hoş geldiniz, güle güle vb. eksantrik birşeyler daha ekledim,,

şimdilik son hali aşağıda, yeni güncelleme olursa atarım buraya,,,

dosya eklemede sınır varmı bilmiyorum, umarım hakkım tükenmiyordur,,,

 

[ntamero]

Bunun sayfa koruma şifresi nedir arkadaşlar ?