makro ile veri filtreleme

[kemal turan]

Merhaba arkadaşlar,
Fonksiyonlar bölümünde ihtiyacımı anlatamadım veya yanlış başlık seçtimki cevap alamadım herhalde.
Ek dosyada ihtiyacımı farklı şekilde açıkladım.
Yardımlarınızı bekliyorum.
Tşk.

 

[Korhan Ayhan]

Merhaba,

Siz tıklanan hücre için veri aktarımı istemişsiniz. Doğal olarak fonksiyonlar bölümünde kimsenin dikkatini çekmemiş.

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("N14:N36")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    If Target <> "" Then
        Range("AX14:BA36").ClearContents
        Satır = 14
        Set BUL = Sheets("SATIŞLAR").Range("A:A").Find(Target)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                Cells(Satır, "AX") = BUL.Offset(0, 16)
                Cells(Satır, "AY") = BUL.Offset(0, 10)
                Cells(Satır, "AZ") = BUL.Offset(0, 1)
                Cells(Satır, "BA") = BUL.Offset(0, 9)
                Satır = Satır + 1
                Set BUL = Sheets("SATIŞLAR").Range("A:A").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    End If
    Set BUL = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[kemal turan]

Korhan bey,
Süper olmuş. Çok teşekkür ederim.
Küçük bir isteğim daha olacak .Süzülen verilerin hangi ürüne ait olduğunu bilmek için çift tıklanan hücre bilgisinin AW11 hücresinde görünmesini sağlayabilirmisiniz.
Selametle kalın.

 

[kemal turan]

Korhan bey ayrıca şunu yapabilirsek ala olur.
Sevk planlama sutunundan çekilen verilerden"Sevk oldu"olanların gelmemesini sağlayabilirmiyiz.
Çok teşekkür eder, hayırlı günler dilerim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("N14:N36")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    If Target <> "" Then
        Range("AX14:BA36").ClearContents
        Satır = 14
        Set BUL = Sheets("SATIŞLAR").Range("A:A").Find(Target)
        If Not BUL Is Nothing Then
            Range("AW11") = BUL.Value
            ADRES = BUL.Address
            Do
                If UCase(BUL.Offset(0, 10)) <> "SEVK OLDU" Then
                    Cells(Satır, "AX") = BUL.Offset(0, 16)
                    Cells(Satır, "AY") = BUL.Offset(0, 10)
                    Cells(Satır, "AZ") = BUL.Offset(0, 1)
                    Cells(Satır, "BA") = BUL.Offset(0, 9)
                    Satır = Satır + 1
                End If
                Set BUL = Sheets("SATIŞLAR").Range("A:A").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    End If
    Set BUL = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[kemal turan]

Korhan bey,
Daha ne diyeyim, Allah ne muradınız varsa versin.
Selametle kalın