Veri Getirme İki Şartlı

[igultekin2000]

iyi akşamlar;
Sayfa1 veriler var. D sütununda firmanın sınıfını, E sütunu kapalı olup olmadığını gösteriyor. D sütunundaki firma türüne göre firmaları seçerek sayfa2' ye aktarmak istiyorum. Veri aktarılırken E sütunundaki kapanış tarihi olmayanların gelmesi şartıyla. Yani E sütununda kapanış tarihi varsa o verilerin gelmemesi şeklinde.
Teşekkür ederim.

 

[Saban Sertkaya]

Merhabalar,
alternatif link lütfen.

 

[Korhan Ayhan]

Deneyiniz.

Sub Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    Dim S1 As Worksheet, Kriter1 As String, Kriter2 As String, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sayfa2")
      
    S1.Range("A2:D" & S1.Rows.Count).Clear
    
    Kriter1 = S1.Range("E1").Value
    Kriter2 = S1.Range("F1").Value
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
          
    Sorgu = "Select F1,F2,F3,F4 From [Sayfa1$A2:E] Where " & _
            "F4 In ('" & Kriter1 & "','" & Kriter2 & "') And F5 Is Null"
            
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        S1.Range("A2").CopyFromRecordset Kayit_Seti
        S1.Range("A1:D" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Borders.LineStyle = 1
        S1.Columns.AutoFit
        Application.ScreenUpdating = True
        
        MsgBox "Seçtiğiniz kriterlere uygun kayıtlar listelenmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Seçtiğiniz kriterlere uygun kayıt bulunamadı!", vbExclamation
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
  
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
End Sub

 

[Saban Sertkaya]

alternatif link lütfen.

Ya da boşverin

 

[igultekin2000]

Deneyiniz.
Teşekkür ederim, sorunsuz çalışıyor, iyi çalışmalar.