belirli değere göre arama listeleme yardım...

[lepricon]

Herkese hayırlı günler dilerim;
benim şöyle bir yardıma ihtiyacım olacak
a sütunundan h sütununa kadar data içeren yaklaşık 5000 satırlık bir tablom var
bu tabloda d sütununda bulunan satırlarda sadece istediğim verileri içeren dataların bulunduğu satırları sayfa 2 ye otomatik olarak attırabilirmiyiz

şöyle ki:

d sütunu
a
a
b
c
d
a
c

olduğunu var sayarsak
ben burada sadece a ve c satırlarını komple 2. sayfaya atmak istiyorum
istediğim şey burada birden fazla değere göre arama yapabilmeliyim

yardımcı olabileceklere şimdiden teşekkür ederim...

 

[Orion1]

Ekli dosyayı inceleyiniz.
ÇÖZÜM = ADO-SQL

Sub aktar_ado_59()
Dim conn As Object, rs As Object
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A2:H65536").ClearContents
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "provider=microsoft.jet.oledb.4.0;Data source=" & _
ThisWorkbook.FullName & ";Extended properties=""Excel 8.0;hdr=no;imex=1"";"
rs.Open "Select * from [Sayfa1$A2:H65536] where F4 ='a' or F4 ='c';", conn, 1, 1
If rs.RecordCount > 0 Then
    Sheets("Sayfa2").Select
    Range("A2").CopyFromRecordset rs
    Application.ScreenUpdating = True
    MsgBox "Veriler aktarıldı" & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Application.ScreenUpdating = True
rs.Close: conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub

 

[lepricon]

öncelikle ilginiz için çok teşekkür ederim;
sadece bir konuda daha yardım istiyorum
o da şu:
a ve c değerleri sürekli değişebileceğinden benim yazmış veya seçmiş olduğum dataları listelerse tam çözüm olur benim için
şimdiden teşekkürler

 

[Orion1]

öncelikle ilginiz için çok teşekkür ederim;
sadece bir konuda daha yardım istiyorum
o da şu:
a ve c değerleri sürekli değişebileceğinden benim yazmış veya seçmiş olduğum dataları listelerse tam çözüm olur benim için
şimdiden teşekkürler

Dosyanız ektedir.

Sub aktar_ado_59()
Dim conn As Object, rs As Object, aranacak As String
Dim i As Integer, strsql As String
Sheets("Sayfa1").Select
For i = 2 To Cells(65536, "L").End(xlUp).Row
    If Cells(i, "L").Value = "" Then
        MsgBox "Boş dğer tespit edildi." & vbLf & "Aranacaklar listesinde boş değer olamaz." _
        & vbLf & "İşlem iptal edildi", vbCritical, "UYARI"
        Cells(i, "L").Select
        Exit Sub
    End If
    aranacak = aranacak & "F4='" & Cells(i, "L").Value & "' or "
Next i
If WorksheetFunction.CountA(Range("L2:L65536")) = 0 Then
    strsql = "Select * from [Sayfa1$A2:H65536];"
    Else
    aranacak = Left(aranacak, Len(aranacak) - 4)
    strsql = "Select * from [Sayfa1$A2:H65536]  where " & aranacak & ";"
End If
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A2:H65536").ClearContents
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "provider=microsoft.jet.oledb.4.0;Data source=" & _
ThisWorkbook.FullName & ";Extended properties=""Excel 8.0;hdr=no;imex=1"";"
'rs.Open "Select * from [Sayfa1$A2:H65536] where F4 ='a' or F4 ='c';", conn, 1, 1
rs.Open strsql, conn, 1, 1
If rs.RecordCount > 0 Then
    Sheets("Sayfa2").Select
    Range("A2").CopyFromRecordset rs
    Application.ScreenUpdating = True
    MsgBox "Veriler aktarıldı" & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Application.ScreenUpdating = True
rs.Close: conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub

 

[lepricon]

ellerinize sağlık teşekkür ederim çözüm için

 

[Orion1]

ellerinize sağlık teşekkür ederim çözüm için

Rica ederim.
İyi çalışmalar.