• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Filtreli sayfada makro çalışmıyor

E

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba arkadaşlar daha öncede sormuştum ama cevap alamadım ve benim için çok önemli olduğu için ısrar ediyorum kusura bakmayın lütfen

Ekteki dosyamda aşağıdaki gibi bir kod var bu kod sayfada filtre uyguladığım ve bir adet malzemeyi seçtiğim zaman çalışmıyor sadece görünenler üzerinden işlem yapıyor bunu sayfa üzerindede anlattım. nasıl bişey yapmalıyım ki sayfada filtre üzerinde seçim yapsam bile bütün malzemeleri dikkate alsın
Lütfen ACİL yardım
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim son As Long, c As Range, Adr As String, deg1, deg2, k As Range
    If Intersect(Target, [B3:C65500]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    If Target = "" Then Exit Sub
    With Target
    If .Column = 2 Then
    If .Offset(0, -1) = "" Then
    .ClearContents
    MsgBox "Önce Referans Girin", , "             PFI"
    Exit Sub
    End If
    With Range("B:B")
    Set c = .Find(Target.Value, , xlValues, xlWhole)
    If Not c Is Nothing Then
    Adr = c.Address
     Do
     deg1 = UCase(Replace(Replace(Cells(c.Row, "A"), "ı", "I"), "i", "İ"))
     deg2 = UCase(Replace(Replace(Target.Offset(0, -1), "ı", "I"), "i", "İ"))
     If deg1 <> deg2 Then
    MsgBox "Yanlış Raf Girişi.." & Chr(10) & "Bu Raf " & _
    deg1 & " Ürününe Aittir.", , "             PFI"
    Target.ClearContents
    Exit Sub
    End If
    Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> Adr
     End If
     End With
      End If
       End With
    Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Merhaba,

Find komutu filtre edilen hücrelerde arama yapmadığı için sorun yaşamışsınızdır.

Kodları silerek aşağıdakileri kullanın.
Kodun mantığı, önce filtreyi kaldırır işlemden sonra tekrar filtre koyar.
Direk döngü ile de yapılabilirdi fakat daha hızlı olduğu için find komutunu bozmadım.

Kod: 
Dim deg As String
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim son As Long, c As Range, Adr As String, deg1, deg2, k As Range, a As Byte
 
    If Intersect(Target, [B3:C65500]) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
        a = 0
        On Error Resume Next
        If Target = "" Then Exit Sub
        With Target
            If .Column = 2 Then
                If .Offset(0, -1) = "" Then
                    .ClearContents
                    MsgBox "Önce Referans Girin", , "             PFI"
                    Exit Sub
                End If
                If ActiveSheet.FilterMode = True Then
                    ActiveSheet.Range("$A$2").AutoFilter Field:=.Column
                    a = 1
                End If
                With Range("B:B")
                    Set c = .Find(Target.Value, , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        Adr = c.Address
                        Do
                            deg1 = UCase(Replace(Replace(Cells(c.Row, "A"), "ı", "I"), "i", "İ"))
                            deg2 = UCase(Replace(Replace(Target.Offset(0, -1), "ı", "I"), "i", "İ"))
                            If deg1 <> deg2 Then
                                MsgBox "Yanlış Raf Girişi.." & Chr(10) & "Bu Raf " & _
                                deg1 & " Ürününe Aittir.", , "             PFI"
                                Target.ClearContents
                                If a = 1 Then
                                    ActiveSheet.Range("$A$2").AutoFilter Field:=Target.Column, _
                                    Criteria1:=deg, Operator:=xlOr, Criteria2:="="
                                End If
                                Exit Sub
                            End If
                            Set c = .FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> Adr
                    End If
                End With
            End If
        End With
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    deg = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Value
End Sub
.
 
Ömer abi teşekkür ederim beni yine çok büyük bir dertten kurtardın eline koluna sağlık.
Yanlız abi B2 hücresindeki sıkıntısız çalışıyor seçimleri A2 veya C2 de yaparsam yine karıştırıyor B2 yi örnek olarak vermiştim diğerlerinide B2 gibi buna nasıl dahil edebiliriz yani ben seçimi diğerlerindede yaparsam aynı olay olsun
 
C yada A sütunu ile bir bağlantı kuramadım. Eski kodlar filtre edilmeden bu sütunlarda ne gibi bir işlem yapıyordu.

With Range("B:B")
Set c = .Find(Target.Value, , xlValues, xlWhole)

Bu bölüm eski kodlarda da var. Tetiklenen hücredeki değeri sadece B sütununda arar.

.
 
With Range("B:B")
Set c = .Find(Target.Value, , xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
deg1 = UCase(Replace(Replace(Cells(c.Row, "A"), "ı", "I"), "i", "İ"))
deg2 = UCase(Replace(Replace(Target.Offset(0, -1), "ı", "I"), "i", "İ"))
If deg1 <> deg2 Then
MsgBox "Yanlış Raf Girişi.." & Chr(10) & "Bu Raf " & _
deg1 & " Ürününe Aittir.", , " PFI"

Eski kodda şöyle bir durum var B:B de yazdığım değeri A:A ya bakıyor ve yazdığım değer başka bir referansta kullanılmıyorsa kabul ediyor eğer kullanıyorsa diyorki bu raf şu referansa aittir diye mesaj veriyor evet C sutununda bir olay yok ama 3 sutunada filtre uyguladığım için hepsi için geçerli olabilirmi diye söylemiştim ben süzme yaparken A dan ve B den seçimler yapıyorum çünkü bu satırlar 2000 lere kadar çıkıyor seçimlerimi yapıyorum sonrasında adreslerini değiştiriyorum
 
Açıklamanızı anlamasam da, #2 numaralı mesajdaki kodları sütuna göre güncelledim. Tekrar denermisiniz.
 
Abi kusura bakma ama gerçekten anlatamadım
önceki mesajınızdaki kodlar gayet güzeldi fakat sadece B2 hücresindeki filtre seçimlerimde çalışıyordu kod
Filtre seçimlerimi A2 hücresinde yaparsam veya A2 ve B2 hücrelerinde yaparsam ozaman çalışmıyor eskisi gibi oluyor demek istedim
ama anlatamadım
 
emr123' Alıntı:
Abi kusura bakma ama gerçekten anlatamadım
önceki mesajınızdaki kodlar gayet güzeldi fakat sadece B2 hücresindeki filtre seçimlerimde çalışıyordu kod
Filtre seçimlerimi A2 hücresinde yaparsam veya A2 ve B2 hücrelerinde yaparsam ozaman çalışmıyor eskisi gibi oluyor demek istedim
ama anlatamadım
Genişletmek için tıkla ...

Ömer abi bu şekilde yapmam mümkün değilmi peki bana yardımcı olursan sevinirim.
 
Her şekilde olabilir, ben sadece olayı tam anlamaya çalışıyorum.

Filtre edilmiş alanda veri girişinden sonra filtre otomatik kalksa sorun olur mu?
 
Benim amacım filtreleme yapmadan önceki calışan makronun filtreledikten sonrada aynı çalışması
Bunun ne şekilde olduğu önemli değil önemli olan hatayı enğellemesi sizin ilk mesajınızdaki kod gayet çok iyiydi
fakat sadece B2 hücresindeki filtreden seçim yaparsam geçerliydi bunu A2 hücresindeki filtreden seçim yaparsamda geçerli olması aslında karışık değil ama anlatamıyorum
 
İlk kodları Module ekleyip bu module yapıştırın.

Kod: 
Public sut As Integer, a1 As Variant
Sub FiltreSutun()
 
    Dim i As Integer, c As Range
    
    sut = 0
    With ActiveSheet.AutoFilter
        For i = 1 To .Filters.Count
            If .Filters(i).On Then
                sut = .Range(1, i).Column
            End If
        Next i
    End With
   
    For Each c In Range(Cells(3, sut), _
        Cells(3, sut).End(xlDown)).SpecialCells(xlCellTypeVisible).Cells
        a1 = c.Value
        Exit Sub
    Next c
End Sub

Aşağıdaki kodları ise, çalışma sayfasındaki eski kodları silip daha sonra kopyalayın.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim son As Long, c As Range, Adr As String, deg, deg1, deg2
 
    If Intersect(Target, [A3:C65500]) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    On Error Resume Next
    With Target
        If .Value = "" Then Exit Sub
        If Cells(.Row, "A") = "" Then
            .ClearContents
            MsgBox "Önce Referans Girin", , "             PFI"
            Exit Sub
        End If
        FiltreSutun
        If sut <> 0 Then
            ActiveSheet.Range("A2").AutoFilter
        End If
        Set c = Range("B:B").Find(Cells(.Row, "B"), LookAt:=xlPart)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                deg1 = UCase(Replace(Replace(Cells(c.Row, "A"), "ı", "I"), "i", "İ"))
                deg2 = UCase(Replace(Replace(Cells(.Row, "A"), "ı", "I"), "i", "İ"))
                If deg1 <> deg2 Then
                    MsgBox "Yanlış Raf Girişi.." & Chr(10) & "Bu Raf " & _
                    deg1 & " Ürününe Aittir.", , "             PFI"
                    Cells(.Row, "B").ClearContents
                    If sut = 1 And sut = 3 Then
                        ActiveSheet.Range("A2").AutoFilter Field:=sut, Criteria1:=a1
                    End If
                    If sut = 2 Then
                        ActiveSheet.Range("A2").AutoFilter Field:=2, Criteria1:=a1, Operator:=xlOr, Criteria2:="="
                    End If
                    Exit Sub
                End If
                Set c = Range("B:B").FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    If sut > 0 Then
        ActiveSheet.Range("A2").AutoFilter Field:=sut, Criteria1:=a1
    End If
    Application.ScreenUpdating = True
    
End Sub

.
 
Merhaba abi mağlesef son gönderdiğinde olmadı

Ama abi ben uğraşarak senin gönderdiklerindende yola çıkarak birşeyler yaptım
ve istediğim gibi olmasına çok az kaldı şuan çalışıyor fakat şurasını yapamadım burda senden destek istiyorum

aşağıda vermiş olduğum kod da kırmızı ile boyadığım yerlerde şöyle bir sıkıntım var benim seçim yapmadığım sutundanda kendi kendine seçim yapıyor ve sadece o kalıyor ekranda benim yapmak istediğim şöyle

Ben 1. sutunda seçim yaparsam kırmızı olan yer sadece 1.sutun için geçerli olsun.Eğer 2.sutunda seçim yaparsam kırmızı olan yer sadece 2.sutun için geçerli olsun.Eğer ben 1.ve 2.sutunda seçim yaparsam kırmızı olan yer 1.ve 2.sutun için geçerli olsun zaten şuandaki durum nerden seçim yaparsam yapayım her iki sutun için geçerli oluyor
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
        
    Dim son As Long, c As Range, Adr As String, deg1, deg2, deg3 As String, deg4 As String, Sb As Worksheet, Yr As Worksheet, k As Range, a As Byte
        
    If Intersect(Target, [B3:C65500]) Is Nothing Then Exit Sub
            
    Set Sb = Sheets("BOŞ ADR")
    Set Yr = Sheets("YER")
        a = 0
        deg3 = Cells(Rows.Count, "A").End(xlUp).Value
        deg4 = Cells(Rows.Count, "B").End(xlUp).Value
    Application.ScreenUpdating = False
    On Error Resume Next
    If Target = "" Then Exit Sub
    With Target
         If .Column = 2 Then
            If .Offset(0, -1) = "" Then
                .ClearContents
                MsgBox "Önce Referans Girin", , "             PFI"
                Exit Sub
            End If
            Set k = Sb.Range("A:B").Find(.Value, , xlValues, xlWhole)
            If Not k Is Nothing Then
                If IsNumeric(.Value) = True Then
                    With Yr.Range("B:B")
                        Set c = .Find(Target.Value, , xlValues, xlWhole)
                        If Not c Is Nothing Then
                            Adr = c.Address
                            Do
                                deg1 = UCase(Replace(Replace(Yr.Cells(c.Row, "A"), "ı", "I"), "i", "İ"))
                                deg2 = UCase(Replace(Replace(Target.Offset(0, -1), "ı", "I"), "i", "İ"))
                                If deg1 <> deg2 Then
                                    MsgBox "Parça Yerde Var Fakat , Yanlış Yer Adresi Yazdınız" & Chr(10) & "Bu Adresde " & _
                                    deg1 & " VAR.", , "                   PFI"
                                    Target.ClearContents
                                    Exit Sub
                                End If
                                Set c = .FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> Adr
                        End If
                    End With
                    son = Yr.Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Range("A" & .Row & ":C" & .Row).Copy Yr.Cells(son, "A")
                    Range("A" & .Row & ":C" & .Row).Delete Shift:=xlUp
                    Yr.Cells(son, "C").Select
                    Exit Sub
                End If
            Else
                MsgBox "Bu Adres Tanımlı Değildir ", , "                    PFI"
                Target.ClearContents
                Exit Sub
            End If
            If IsNumeric(.Value) = False Then
                If ActiveSheet.FilterMode = True Then
                    ActiveSheet.Range("$A$2").AutoFilter Field:=1
                    ActiveSheet.Range("$A$2").AutoFilter Field:=2
                    a = 1
                End If
                With Range("B:B")
                    Set c = .Find(Target.Value, , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        Adr = c.Address
                        Do
                            deg1 = Cells(c.Row, "A")
                            deg2 = Target.Offset(0, -1)
                            If deg1 <> deg2 Then
                                MsgBox "Yanlış Adres Yazdınız.." & Chr(10) & "Bu Adresde " & _
                                deg1 & "   VAR.", , "             PFI"
                                Target.ClearContents
                                Target.Select
                            [COLOR="red"]   If a = 1 Then
                                    ActiveSheet.Range("$A$2").AutoFilter Field:=1, _
                                    Criteria1:=deg3, Operator:=xlOr, Criteria1:="="
                                     ActiveSheet.Range("$A$2").AutoFilter Field:=2, _
                                    Criteria1:=deg4, Operator:=xlOr, Criteria2:="="
                                    Target.Select
                                 End If[/COLOR]                                Exit Sub
                            End If
                            Set c = .FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> Adr
                      [COLOR="Red"]   If a = 1 Then
                             ActiveSheet.Range("$A$2").AutoFilter Field:=1, _
                              Criteria1:=deg3, Operator:=xlOr, Criteria1:="="
                               ActiveSheet.Range("$A$2").AutoFilter Field:=2, _
                               Criteria1:=deg4, Operator:=xlOr, Criteria2:="="
                        End If[/COLOR]             
                   End If
                End With
            End If
        End If
         If .Column = 3 Then
            If .Offset(0, -2) = "" Then
                .ClearContents
                MsgBox "Önce Referans Ve Adres No Girin", , "                   PFI"
                Exit Sub
            End If
        End If
    End With
    Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Ömer hocam kolay gelsin
Konunun çözümü varmı acaba
yardımların için şimdiden teşekkür ederim iyi çalışmalar..
 
Merhaba
Bu kodu dener misiniz_?
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim STR As Long, VR1 As String, VR2 As String
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, [B3:C65500]) Is Nothing Then _
Application.ScreenUpdating = True: _
Application.EnableEvents = True: Exit Sub
VR1 = Cells(Target.Row, "A")
With WorksheetFunction
For STR = 3 To Target.Row - 1
If .CountIf(Range("A3:A" & Target.Row - 1), VR1) > 0 Then
If Cells(STR, "A") = VR1 Then
VR2 = Cells(STR, "B")
If VR2 <> VR1 Then
MsgBox "Yanlış Raf Girişi.." & Chr(10) & "Bu Raf " & _
    VR1 & " Ürününe Aittir.", , "             PFI"
    Cells(Target.Row, "B") = Empty
    Exit For
End If: End If
End If: Next
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
Saygı değer asi_kral hocam öncelikle ilğiniz için teşekkür ederim
fakat verdiğiniz kodu kendime göre düzenleyemedim
Ömer hocamın hazırlamış olduğu kodda sadece kırmızı ile belirtiğim yerde bir sıkıntım vardı ve siz bu sıkıntıyı anlamışsınız ama ben verdiğiniz kodu kendime göre düzenleyemedim mağlesef benim enson verdiğim kod'a bunu nasıl uyarlayabilirim yardımlarınız için teşekkür ederim iyi çalışmalar..
 
emr123' Alıntı:
Saygı değer asi_kral hocam öncelikle ilğiniz için teşekkür ederim
fakat verdiğiniz kodu kendime göre düzenleyemedim
Ömer hocamın hazırlamış olduğu kodda sadece kırmızı ile belirtiğim yerde bir sıkıntım vardı ve siz bu sıkıntıyı anlamışsınız ama ben verdiğiniz kodu kendime göre düzenleyemedim mağlesef benim enson verdiğim kod'a bunu nasıl uyarlayabilirim yardımlarınız için teşekkür ederim iyi çalışmalar..
Genişletmek için tıkla ...

Kodun neyini uyarlayacaksınız onu anlamadım. ( Pis bir huyum var kimsenin verdiği kodu düzenlemem. Kendi kodu mu veririm ) ( daha rahat oluyorda :) )
Benim verdiğim kodun neresinde değişiklik yapmak istiyorsunuz onu söylerseniz yardımcı olmaya çalışırım
 
Beni yanlış anladınız lütfen kusuruma bakmayın.
12 nolu mesaj'ımdaki kod'um sıkıntısız şekilde çalışıyor benim kod üzerinde sıkıntım olan kırmızı ile belirtiğim bölgede burayı düzenleyemedim yoksa kod'un genelinde sıkıntı yok sadece kırmızı olan yerde sıkıntım
kırmızı olan bölgedeki sıkıntım ise filtredeki seçimlerde
aşağıda vermiş olduğum kod da kırmızı ile boyadığım yerlerde şöyle bir sıkıntım var benim seçim yapmadığım sutundanda kendi kendine seçim yapıyor ve sadece o kalıyor ekranda benim yapmak istediğim şöyle

Ben 1. sutunda seçim yaparsam kırmızı olan yer sadece 1.sutun için geçerli olsun.Eğer 2.sutunda seçim yaparsam kırmızı olan yer sadece 2.sutun için geçerli olsun.Eğer ben 1.ve 2.sutunda seçim yaparsam kırmızı olan yer 1.ve 2.sutun için geçerli olsun zaten şuandaki durum nerden seçim yaparsam yapayım her iki sutun için geçerli oluyor
Genişletmek için tıkla ...
 
emr123' Alıntı:
Ömer hocam kolay gelsin
Konunun çözümü varmı acaba
yardımların için şimdiden teşekkür ederim iyi çalışmalar..
Genişletmek için tıkla ...

#11 numaralı mesajdaki kodları değiştirdim, yeni kodları alarak deneyiniz.

Detaylı deneme yapmadım, eğer sonuçlarda hata alırsanız adım adım ne yaptıktan sonra hata aldığınızı açıklarsanız benimde hatayı bulmak okadar kolay olacaktır.

Not: Ben kodları ilk mesajınızdaki dosyaya göre yazdım.

.
 
Hocam teşekkür ederim ama ben anlatamadım kusura bakmayın
yapmak istediğimi dosya ekleyerek tekrar anlattım
Dosya üzerindeki kodlarda hiçbir sıkıntı yok zaten bu kadları siz yazmıştınız
kodlar aynı şekilde kalıcak sadece ek bir isteğim var bunuda dosya üzerinde anlatmaya çalıştım inşallah bu sefer anlatabilmişimdir.
Herşey için Allah razı olsun
 
Son düzenleme:
Bu şekilde olmuyacak sanırım yinede herşey için teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst