makro ile başka sahifeden filtreleme

[kemal turan]

Merhaba arkadaşlar,
Ek dosyada açıklamasını yaptım.
İlgilenecek arkadaşlara teşekkür ederim.

 

[kemal turan]

Forumda bulunan uzman arkadaşlarım,
İsteğim acaba yapılamaz mı ? veya soru şeklimdemi bir sıkıntı var.
Bu hususta cevap yazabilirseniz sevinirim.
Tşk.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [a2:a65536]) Is Nothing Then Exit Sub
[b2:b65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [sayfa2!a65536].End(3).Row
If Sheets("sayfa2").Cells(a, "a") = Target Then
c = c + 1
Cells(c + 1, "b") = Sheets("sayfa2").Cells(a, "b")
End If
Next
End Sub

 

[kemal turan]

Levent bey,
Çözümünüz bir yana ,cevabınız için çok teşekkür ederim.
Çözümünüz de ufak bir sorun ve ilave isteğim var.
Eklediğim dosyaya bir bakarsanız orada açıkladım.
Emeğinize sağlık.

 

[Mahir64]

Yanlış Yorumlamışım.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
c = 0
If Not Intersect(Target, [a2:a65536]) Is Nothing Then
[b2:c65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [sayfa2!a65536].End(3).Row
If Sheets("sayfa2").Cells(a, "a") = Target Then
c = c + 1
If WorksheetFunction.CountIf([b:b], Sheets("sayfa2").Cells(a, "b")) = 0 Then
Cells(c + 1, "b") = Sheets("sayfa2").Cells(a, "b")
End If
End If
Next
End If
If Not Intersect(Target, [b2:b65536]) Is Nothing Then
[c2:c65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [sayfa2!a65536].End(3).Row
If Sheets("sayfa2").Cells(a, "b") = Target Then
c = c + 1
If WorksheetFunction.CountIf([c:c], Sheets("sayfa2").Cells(a, "c")) = 0 Then
Cells(c + 1, "c") = Sheets("sayfa2").Cells(a, "c")
End If
End If
Next
End If
End Sub

 

[kemal turan]

SN.Levent bey,
Süperrrsiniz.
Çok teşekkkür ederim.
Hayırlı geceler.

 

[kemal turan]

Levent bey merhaba,
Küçük bir sorun var ek dosyada açıkladım bir bakarmısınız
Tşk.

 

[kemal turan]

Merhaba Levent bey,
bir bakabilirmisiniz.
Tşk.

 

[kemal turan]

Forumdaki uzmanlarımız merhabalar,
ek dosyaya bir bakabilirseniz.Çok acil lazım.
Tşk.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
c = 0
If Not Intersect(Target, [a2:a65536]) Is Nothing Then
[b2:c65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [sayfa2!a65536].End(3).Row
If Sheets("sayfa2").Cells(a, "a") = Target Then
c = c + 1
If WorksheetFunction.CountIf([b:b], Sheets("sayfa2").Cells(a, "b")) = 0 Then
Cells(c + 1, "b") = Sheets("sayfa2").Cells(a, "b")
End If
End If
Next
[b2:b65536].Sort Key1:=[b2], Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End If
If Not Intersect(Target, [b2:b65536]) Is Nothing Then
[c2:c65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [sayfa2!a65536].End(3).Row
If Sheets("sayfa2").Cells(a, "b") = Target Then
c = c + 1
If WorksheetFunction.CountIf([c:c], Sheets("sayfa2").Cells(a, "c")) = 0 Then
Cells(c + 1, "c") = Sheets("sayfa2").Cells(a, "c")
End If
End If
Next
[c2:c65536].Sort Key1:=[c2], Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End If
End Sub

 

[kemal turan]

Sn.Levent bey,
Çok teşekkür ederim.Kodumuz harika çalıştı.
İşiniz rast gelsin.
Selametle kalın

 

[Levent Menteşoğlu]

Rica ederim. İyi akşamlar dilerim.