+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Gelişmiş Filtre Uygulamak (/konu-gelismis-filtre-uygulamak.html)
Gelişmiş Filtre Uygulamak - yyhy - 30/03/2020
Gelişmiş süzgeç ile kritere göre aradığım bilgileri formülsüz bir şekilde süzmek istiyorum. Verilerim yıllık ve 5000 satır civarında oluyor. Acaba nasıl yapabilirim. Gelişmiş süzgeç mantığını macroya bağlayarak kriterleri girdikten sonra verilerim gelmiş olacak. Yardımcı olan arkadaşlara teşekkür ederim.
Cvp: Gelişmiş Filtre Uygulamak - yyhy - 01/04/2020
Arkadaşlar gelişmiş filtre ile ilgili başka sayfada filtreleme işlemini bir türlü yapamadım acaba yardımcı olabilecek arkadaş var mı?
Cvp: Gelişmiş Filtre Uygulamak - feraz - 01/04/2020
Ado ile yapılmış hali ektedir.
Sub listele()
Dim s As String
Dim con As Object
Dim rs As Object
say = 8
With Sayfa2
Application.ScreenUpdating = False
.Range("D8:M" & Rows.Count).Clear
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"""
s = "select f1,f2,f3,f5,f6,f7,f8,f9,f10,f11 from [Veri$E4:P65536] where not isnull(f1)"
If .Range("D7").Value <> "" Then s = s & " and f1 like '%" & .Range("D7").Value & "%'"
If .Range("E7").Value <> "" Then s = s & " and f2 like '%" & .Range("E7").Value & "%'"
If .Range("F7").Value <> "" Then s = s & " and f3 like '%" & .Range("F7").Value & "%'"
If .Range("g7").Value <> "" Then s = s & " and f5 like '%" & .Range("g7").Value & "%'"
If .Range("H7").Value <> "" Then s = s & " and f6 like '%" & .Range("H7").Value & "%'"
If .Range("I7").Value <> "" Then s = s & " and f7 like '%" & .Range("I7").Value & "%'"
If .Range("j7").Value <> "" Then s = s & " and f8 like '%" & .Range("j7").Value & "%'"
If .Range("k7").Value <> "" Then s = s & " and f9 like '%" & .Range("k7").Value & "%'"
If .Range("L7").Value <> "" Then s = s & " and f10 like '%" & .Range("L7").Value & "%'"
If .Range("M7").Value <> "" Then s = s & " and f11 like '%" & .Range("M7").Value & "%'"
On Error Resume Next
rs.Open s, con, 1
If rs.RecordCount > 0 Then
Do While Not rs.EOF
.Cells(say, 4).Value = rs(0)
.Cells(say, 5).Value = rs(1)
.Cells(say, 6).Value = rs(2)
.Cells(say, 7).Value = Format(rs(3), "dd.mm.yyyy")
.Cells(say, 8).Value = rs(4)
.Cells(say, 9).Value = rs(5)
.Cells(say, 10).Value = rs(6)
.Cells(say, 11).Value = rs(7)
.Cells(say, 12).Value = rs(8)
.Cells(say, 13).Value = rs(9)
say = say + 1
rs.movenext
Loop
End If
Application.ScreenUpdating = True
End With
rs.Close
con.Close
Set con = Nothing
Set rs = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([D7:M7], Target) Is Nothing Then Call listele
End SubCvp: Gelişmiş Filtre Uygulamak - feraz - 01/04/2020
Eğer avaş çalışırsa alttaki gibide yapabilirsiniz.
Private Sub Worksheet_Change(ByVal Target As Range) isterseniz eklediğim dosyadaki soldaki kodu silip Listele makrosunuda çalıştırabilirsiniz.Safa koduolduğu için yavaş olabilir.
Sub listele()
Dim s As String
Dim con As Object
Dim rs As Object
Dim arr
say = 1
With Sayfa2
Application.ScreenUpdating = False
.Range("D8:M" & Rows.Count).Clear
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"""
s = "select f1,f2,f3,f5,f6,f7,f8,f9,f10,f11 from [Veri$E4:P65536] where not isnull(f1)"
If .Range("D7").Value <> "" Then s = s & " and f1 like '%" & .Range("D7").Value & "%'"
If .Range("E7").Value <> "" Then s = s & " and f2 like '%" & .Range("E7").Value & "%'"
If .Range("F7").Value <> "" Then s = s & " and f3 like '%" & .Range("F7").Value & "%'"
If .Range("g7").Value <> "" Then s = s & " and f5 like '%" & .Range("g7").Value & "%'"
If .Range("H7").Value <> "" Then s = s & " and f6 like '%" & .Range("H7").Value & "%'"
If .Range("I7").Value <> "" Then s = s & " and f7 like '%" & .Range("I7").Value & "%'"
If .Range("j7").Value <> "" Then s = s & " and f8 like '%" & .Range("j7").Value & "%'"
If .Range("k7").Value <> "" Then s = s & " and f9 like '%" & .Range("k7").Value & "%'"
If .Range("L7").Value <> "" Then s = s & " and f10 like '%" & .Range("L7").Value & "%'"
If .Range("M7").Value <> "" Then s = s & " and f11 like '%" & .Range("M7").Value & "%'"
On Error Resume Next
rs.Open s, con, 1
If rs.RecordCount > 0 Then
ReDim arr(1 To rs.RecordCount, 1 To 10)
Do While Not rs.EOF
arr(say, 1) = rs(0)
arr(say, 2) = rs(1)
arr(say, 3) = rs(2)
arr(say, 4) = Format(rs(3), "dd.mm.yyyy")
arr(say, 5) = rs(4)
arr(say, 6) = rs(5)
arr(say, 7) = rs(6)
arr(say, 8) = rs(7)
arr(say, 9) = rs(8)
arr(say, 10) = rs(9)
say = say + 1
rs.movenext
Loop
.Range("d8").Resize(say - 1, 10).Value = arr
End If
Application.ScreenUpdating = True
End With
rs.Close
con.Close
Set con = Nothing
Set rs = Nothing
Erase arr
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([D7:M7], Target) Is Nothing Then Call listele
End SubCvp: Gelişmiş Filtre Uygulamak - feraz - 01/04/2020
Yada sadece bu kodu Arama safasınının kod yerine yapıştırınz.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
With Sheets("Veri")
If Not Intersect([D7:M7], Target) Is Nothing Then
[D9:P1048576].Clear
.Range("E3:P" & .Cells(Rows.Count, "D").End(3).Row).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("D6:O7"), CopyToRange:=Range("D9")
End If
End With
Application.ScreenUpdating = True
End SubCvp: Gelişmiş Filtre Uygulamak - yyhy - 02/04/2020
Sayın feraz emeğinize sağlık. Sayfa aramada sol tarafta bulunan form denetimi tiklerinden işaretlediğim zaman verileri getirmiyor. Acaba neden olabilir? Son kod da ilgili yerlere veriyi getirmiyor veri sayfasının başlıklarını falan getiriyor. Ayarlamaya çalıştım ama yapamadım. Acaba son kod a bir daha bakabilirmisiniz uygun zamanda. Teşekkür ederim.