çok koşullu veri süzme

[ÇAĞRIBEY1]

Herkese iyi günler diliyorum.
Link verdiğim örnek dosyada işin içinden çıkamadım. Yardım edecek olan ustalarıma şimdiden teşekkür ederim.
http://www.dosya.tc/server39/oQZa1n/DENEMEKURSL_STES_.xlsx.html

 

[samet_can]

Benzer bir çalışmada aşağıda ki kodlar kullanılmıştır.
İlgili arkadaşlar aşağıdaki kodu çalışmanıza uyarlayabileceğini umuyorum ben hata aldım.

Sub DENEME()
    Dim i%, sut%, a%, s%
    With ANA_SAYFA
        sut = .Cells(1, Columns.Count).End(1).Column: s = 1
        For i = 2 To .Range("A65536").End(3).Row
            For a = 2 To sut
                If .Cells(i, a) = "X" Then
                    DERS.Cells(s, 1) = .Cells(i, "A")
                    DERS.Cells(s, 2) = .Cells(i, a).End(3).Value
                    s = s + 1
                End If
            Next a
        Next i
    End With
    s = Empty: a = Empty: sut = Empty: i = Empty
End Sub

 

[ÇAĞRIBEY1]

Teşekkürler. Bu kodları çalışmama uyarlayacak kadar MAKRO bilgim yoktur. Bu konuda yardıma ihtiyacım var.

 

[ÇAĞRIBEY1]

Bu sorunun cevabı yok galiba...
Sağlık olsun.

 

[Orion1]

Dosyanız linktedir.

DOSYAYI..... İ N D İ R İ N İ Z...............

Sub aktar59()
Dim k As Range, sut As Byte, i As Long, sat As Long, sh As Worksheet
Dim sonsut As Byte, sonsat As Long
Sheets("DERS").Select
Set sh = Sheets("ANA SAYFA")
sonsut = sh.Cells(1, 256).End(xlToLeft).Column
Set k = sh.Range(sh.Cells(1, 5), sh.Cells(1, sonsut)).Find(Range("F1").Value, , xlValues, xlWhole)
If k Is Nothing Then
    MsgBox "[ " & Range("K1").Value & " ]  Bulunamadı!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Set k = Nothing
    Exit Sub
Else
    sut = k.Column
End If
Range("B3:E" & Rows.Count).ClearContents
sat = 3
sonsat = sh.Cells(Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To sonsat
    If UCase(sh.Cells(i, sut).Value) = "X" Then
        Cells(sat, "B").Value = sh.Cells(i, "B").Value
        Cells(sat, "C").Value = sh.Cells(i, "C").Value
        Cells(sat, "D").Value = sh.Cells(i, "D").Value
        sat = sat + 1
    End If
Next i
Set sh = Nothing
Set k = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[ÇAĞRIBEY1]

Evren Hocam;
Yardımlarınız için binlerce teşekkür ederim. Günlerce uğraşacağım dosyayı 10 dakika içinde bitirme imkanı veren bir yardımda bulundunuz. İyi ki varsınız...