AccessTr.neT

(02/04/2020, 21:29)yyhy yazdı: [ -> ]Sayın farez butonlara hazırlamış olduğunuz macroyu atadım. Macro tam istediğim gibi olmuş yalnız; 1774/Ek-6 -S.K.M. tiki ne tıkladığım zaman verileri normal filitre ediyor. TÜMÜ tiki ne tıkladığımda veriyi bir satır boşluk vererek getiriyor. Dosyayı ekliyorum bir daha bakabilir misiniz?
Sayın farez yukarıda Mehmet hocamızdan vermiş olduğunuz videoyu izledim. Hobi amaçlı o küçük programın aynısını yaptım bunda sıkıntı yaşadım.Yukarıda bahsettiğim yeri de yapabilirsem sayenizde bunu da çözmüş olacağım. Teşekkürler.

Dosyayı unutmuşsunuz.
Alttaki koddaki +1 i silip tümü olayı için deneyin.

sonVeri = .Cells(Rows.Count, "D").End(3).Row + 1

Dosyayı ekliyorum. (+1 i sildim.)Kodları değiştirdim ama yine bir satır boş bırakıyor tümü nde.

Sayın Farez bey veri sayfasında 2. satır boşmuş orayı doldurunca sorun halledildi. Teşekkür ederim. Ama örnek bir dosya var diye yazmışsınız eğer bulursanız eklerseniz sevinirim. İyi akşamlar ihtiyaca cevap verdi elleriniz dert görmesin tekrar teşekkürler.

(02/04/2020, 23:24)yyhy yazdı: [ -> ]Ama örnek bir dosya var diye yazmışsınız

Rica ederim dosya var derken o dosanın kodlarını uyarladım.

Bu konu ile alakası ok aslında isterseniz onuda eklebilirim userformlu ve kendim için biraz gelişmiş olarak hazırlamıştım.

Tümü için boş gelmesi sebebi  veri = .Range("E4:P" & sonVeri).Value burdaki 4 ü 5 yaparsanızda sorun olmaz.ilk ekte 4.cü satır doludu hatırladığım.


Ayrıca eğer veri sayfası E sütunu arasında boşluklar olmazsa alttaki koduda kullanabilirsiniz.

With Sayfa1

            If .Range("E5").Value = "" Then

                Sayfa2.Range("D8:M" & Rows.Count).ClearContents

                GoTo son

            End If

            sonVeri = (.Range("E5", .Range("E5").End(xlDown)).Count - 1) + 5 '5 demek 5.ci satirdan basladigi icin

            veri = .Range("E5:P" & sonVeri).Value

        End With

Yukardaki kodu ekledim öncekinden ReDim arr(1 To 12, 1 To UBound(veri, 1)) satırına kadar yerleri.

Sub listele()

    

        Dim veri, sonVeri As Integer, key1, key2, say As Integer, i As Integer

        

        With Sayfa1

            If .Range("E5").Value = "" Then

                Sayfa2.Range("D8:M" & Rows.Count).ClearContents

                GoTo son

            End If

            sonVeri = (.Range("E5", .Range("E5").End(xlDown)).Count - 1) + 5 '5 demek 5.ci satirdan basladigi icin

            veri = .Range("E5:P" & sonVeri).Value

        End With

        

        ReDim arr(1 To 12, 1 To UBound(veri, 1)) '12 arama saydasi D ile P arasi sütun sayisi

        

        With Sayfa2

            If WorksheetFunction.CountA(.Range("D7:M7")) = 0 Then

                .Range("D8:M" & Rows.Count).ClearContents

                GoTo son

            End If

            

            key1 = "*" & .Range("D7").Value & "*|*" & .Range("E7").Value & "*|*" & .Range("F7").Value & "*|*" & .Range("G7").Value & "*|*" & _

                        .Range("H7").Value & "*|*" & .Range("I7").Value & "*|*" & .Range("J7").Value & "*|*" & _

                        .Range("K7").Value & "*|*" & .Range("L7").Value & "*|*" & .Range("M7").Value & "*"

        End With

        

        For i = LBound(veri) To UBound(veri)

            key2 = "*" & veri(i, 1) & "*|*" & veri(i, 2) & "*|*" & veri(i, 3) & "*|*" & veri(i, 5) & _

                                      "*|*" & veri(i, 6) & "*|*" & veri(i, 7) & "*|*" & veri(i, 8) & _

                                      "*|*" & veri(i, 9) & "*|*" & veri(i, 10) & "*|*" & veri(i, 11) & "*"

            If CStr(key2) Like CStr(key1) Then

                say = say + 1

                arr(1, say) = veri(i, 1)

                arr(2, say) = veri(i, 2)

                arr(3, say) = veri(i, 3)

                arr(4, say) = veri(i, 5)

                arr(5, say) = veri(i, 6)

                arr(6, say) = veri(i, 7)

                arr(7, say) = veri(i, 8)

                arr(8, say) = veri(i, 9)

                arr(9, say) = veri(i, 10)

                arr(10, say) = veri(i, 11)

            End If

        Next

        

        With Sayfa2 '******

            .Range("D8:M" & Rows.Count).ClearContents

            If say > 0 Then

                ReDim Preserve arr(1 To UBound(arr), 1 To say)

                .Range("D8").Resize(say, 10).Value = Application.Transpose(arr)

            End If

        End With '******

son:

        On Error Resume Next

        

        Application.ScreenUpdating = True

        

        Erase arr: key1 = vbNullString: key2 = vbNullString: Erase veri

End Sub

Dediğim dosyada ekte.Eşittir,içerir,ilk karaktere,son karaktere göre gibi seçimler apılıyor.

Emeğinize sağlık çok teşekkür ederim. Konu çözülmüştür.