Makro ile başka bir excelden istenen verileri alma

[KARTAL133]

Merhaba @Korhan Ayhan

Kontrol ettim 6 Sutuna bittiyor 25 veya 40 sutune kadar aynı uygulamayı koyduğum zaman çalışmıyor.
sanırım 6 Sutunda bitiyor kopyalama sınırlama olmuş gibi oldu

 

[KARTAL133]

Merhaba @Korhan Ayhan Hocam

Mantığını anladım hal ettim.
Çok teşekkürler emeğinize sağlık

 

[Hacı Bayram ÖZKAN]

Korhan hocam çok özür dilerim araya giriyorum ama, aynı dosya için ben aramayı bir hücreye atadım

Set My_Recordset = My_Connection.Execute("Select * From [Sayfa1$] Where F6 = '" & Range("H1").Value & "'")

Mesajla nasıl bir değişiklik yapmam lazım yani iki veriyide almak istiyorum, önce YES leri sonra noları, alt alta bunun içinde koşul vermek istiyorum,
Eski veriler silin veya silinmesin diye bu nasıl düzenlenir.

'
'
'
UYARI = MsgBox("Eski veriler silinsin mi?", vbYesNo, "DİKKAT")
'
'
If UYARI = vbYes Then Range("A2:F" ).ClearContents
'
'Teşekkür ederim.
End If

 

[Korhan Ayhan]

Deneyiniz.

İki veriyide almak istediğiniz için sorguyu değiştirdim. Hücre olayını iptal ettim. Ama istenirse hücre de kullanılabilir.

Option Explicit

Sub Import_Data()
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_File As String, Process_Time As Double
 
    Process_Time = Timer
  
    If MsgBox("Eski veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2, "Dikkat!") = vbYes Then Range("A2:F" & Rows.Count).Clear
 
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
 
    My_File = ThisWorkbook.Path & Application.PathSeparator & "Kapalı.xlsx"
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    My_File & ";Extended Properties=""Excel 12.0;Hdr=No"""
     
    Set My_Recordset = My_Connection.Execute("Select * From [Sayfa1$] Where F6 In ('No','Yes')")
  
    Cells(Rows.Count, 1).End(3)(2, 1).CopyFromRecordset My_Recordset
    
    Columns.AutoFit
  
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
  
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[Hacı Bayram ÖZKAN]

Sayın abim eline sağlık isteğim bu idi, abim hücreye yazmamın sebebi sizin kodda Yes ve No ları alıyor, ben bunu başka dosya için yapacağım örneğin Rütbeleri seçmek gibi... Teşekkürler iyi varsınız.

 

[KARTAL133]

Merhaba Hocam

Kapalı olan dosyadaki "No" ala Açık dosyaya ala biliyorum sorun yok.
Kapalı olan dosyan çekilen "No" silinmesi mümkün mü?

 

[Korhan Ayhan]

Silme işlemi için dosyayı açmak gerekir.

 

[KARTAL133]

Merhaba Hocam

Silme işilemi için kaplı dosya acarak yapalım.
TC numaraları aynı olanlarda "Yes/No" olan sütünlarda biri "yes" diğeri de "No" ise "yes" kalacak "no" olanlar silecek
tabi "Yes/No" kolunda sadece bir tane "No" varsa o kalacak eğer 2 veya 3 tane "no" olursa silinecek.

yardımlarınızı için teşekkürler

 

[Korhan Ayhan]

Paylaştığınız dosyaya göre aşağıdaki kod ile belirttiğiniz satırlar siliniyor.

Verilerinizi yedekleyerek siz de deneyiniz.

Option Explicit

Sub Kosullu_Satir_Sil()
    Dim Zaman As Double, Son As Long, X As Long
    Dim Yes_Say As Long, No_Say As Long
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Son = Cells(Rows.Count, 1).End(3).Row
  
    For X = Son To 2 Step -1
        Yes_Say = WorksheetFunction.CountIfs(Range("A:A"), Cells(X, 1), Range("G:G"), "Yes")
        No_Say = WorksheetFunction.CountIfs(Range("A:A"), Cells(X, 1), Range("G:G"), "No")
        If Yes_Say = 1 And No_Say = 1 Then
            If Cells(X, "G") = "No" Then Rows(X).Delete xlUp
        End If
        If Yes_Say > 1 Or No_Say > 1 Then
            Rows(X).Delete xlUp
        End If
    Next
        
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    MsgBox "Mükerrer TC numaraları kontrollü şekilde silinmiştir." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub