Makro ile başka bir excelden istenen verileri alma

[KARTAL133]

Merhaba Arkadaşlar

Elimde iki excel var Data excelden bütün verileri var. İstenen sutunlar Genel Dosya Almak istiyorum.
Data dosyasında "yes " ve "No" olanlar bulunmaktadır. "No" olanları Genel dosya almak istiyorum.
bütün sütünlar değil belirli olan sütünları konu ile makro nasıl yapa biliriz.
şimdiden yardımlarınızı için çok teşekkürler

 

[ÖmerFaruk]

Forumda arama menüsünde Adodb.Connection diyerek arama yapınca bir sürü çok benzer çalışma bulabilirsiniz.

https://www.excel.web.tr/search/245023/?q=adodb.Connection&o=date

 

[KARTAL133]

Merhaba Hocam

Araştırma yaptım istediğimi bulamadım
konu açıklması değişti

Kapalı Dosya ve Açık dosya olarak iki doysa var
Açık dosyada "Yes" olanları kapalı dosya aktarımı yapacam.

Yardımcı olmanızı rica ederim.

 

[KARTAL133]

Merhaba Hocam

Araştırma yaptım istediğimi bulamadım
konu açıklması değişti

Kapalı Dosya ve Açık dosya olarak iki doysa var
Açık dosyada "Yes" olanları kapalı dosya aktarımı yapacam.

Yardımcı olmanızı rica ederim.

Yes olan Verileri aktardıktan sonra "Yes" olanlardan açık olan dosyadan silinecek

 

[KARTAL133]

Yardımcı olacak var mı

 

[KARTAL133]

@Ömer hocam yardımıcı ola bilirminiz

 

[Korhan Ayhan]

Merhaba,

İlk mesajınızda "No" olanları aktarmak istediğinizi belirtmişsiniz. Fakat sonraki mesajlarınızda ise "Yes" olarak değişiklik yapmışsınız. Bu tarz tezatlıklar kafa karıştırıyor ve sorunuza cevap almanızı zorlaştırıyor.

Soru sormak bu kadar zor olmamalı diye düşünüyorum.

 

[KARTAL133]

Merhaba @Korhan Ayhan Hocam

Evet haklısınız

Söyle bir sey istiyorum. Kapalı dosyaya "Yes" olan veriler aktarılacak "No" olanlar açık olan dosyada kalacak.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Export_Data()
    Dim K1 As Workbook, S1 As Worksheet
    Dim XL_App As Object, K2 As Workbook, S2 As Worksheet
    Dim Process_Time As Double, Last_Row As Long
    Dim File_Path As String, My_File As String
    Dim My_Data As Variant, Count_Data As Long, X As Long
    Dim WF As WorksheetFunction, Delete_Area As Range
    
    Process_Time = Timer
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    Set WF = WorksheetFunction
    
    Set XL_App = VBA.CreateObject("Excel.Application")
    XL_App.Visible = False
    
    File_Path = K1.Path & "\"
    
    My_File = Dir(File_Path & "Genel Dosya.xlsx")
    
    If My_File <> "" Then
        Set K2 = XL_App.Workbooks.Open(File_Path & My_File)
        Set S2 = K2.Sheets("Sayfa1")
        
        On Error Resume Next
        S1.ShowAllData
        S2.ShowAllData
        On Error GoTo 0
        
        Last_Row = S2.Cells(S2.Rows.Count, 1).End(3).Row
        If Last_Row = 1 Then
            S2.Range("A1:D1") = Array("Adı Soyadı", "İl", "Okul", "Yes/No")
            Last_Row = Last_Row + 1
        Else
            Last_Row = Last_Row + 1
        End If
        
        My_Data = S1.Range("A2:F" & WF.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)).Value
        
        ReDim My_List(1 To UBound(My_Data, 1), 1 To 4)
        
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            If My_Data(X, 6) = "Yes" Then
                Count_Data = Count_Data + 1
                My_List(Count_Data, 1) = My_Data(X, 1)
                My_List(Count_Data, 2) = My_Data(X, 2)
                My_List(Count_Data, 3) = My_Data(X, 5)
                My_List(Count_Data, 4) = My_Data(X, 6)
                
                If Delete_Area Is Nothing Then
                    Set Delete_Area = S1.Cells(X + 1, 1)
                Else
                    Set Delete_Area = Union(Delete_Area, S1.Cells(X + 1, 1))
                End If
            End If
        Next
        
        If Count_Data > 0 Then S2.Cells(Last_Row, 1).Resize(Count_Data, 4) = My_List
        
        K2.Close 1
    
        If Not Delete_Area Is Nothing Then Delete_Area.EntireRow.Delete Shift:=xlUp
    End If
    
    XL_App.Quit
    
    Set XL_App = Nothing
    Set WF = Nothing
    Set Delete_Area = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "Aktarılan  veri sayısı ; " & Count_Data & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[KARTAL133]

@Korhan Ayhan Çok teşekkürler Hocam Elinize sağlık

 

[KARTAL133]

Merhaba @Korhan Ayhan Hocam

Sizden bir rica daha bulunacam Kapalı dosyadan "No" olanları çeke bilirmiyiz.

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

 

[Korhan Ayhan]

Merhaba,

Bu tarz değişiklikleri kendinizde yapabilirsiniz.

Kod içinde geçen aşağıdaki satırı bulup Yes yazan yeri No olarak düzeltirseniz sonuca ulaşabilirsiniz.

If My_Data(X, 6) = "Yes" Then

 

[KARTAL133]

Merhaba Hocam

Evet onu yapa biliyorum kapalı dosyadan "No" olanları almak için söyledim

 

[Korhan Ayhan]

Dediğim değişikliği yaparak denediniz mi?

Yoksa ben mi sorunuzu yanlış anladım..

 

[KARTAL133]

Merhaba Hocam

Evet yaptım kapalı dosyaya No olanladar gidiyor
Benim istediğim kapalı dosyadan No olanlar açık dosyaya çekmek

 

[Korhan Ayhan]

Yani paylaştığınız ilk mesajınızdaki dosyalara göre Genel Dosya'dan Data dosyasına No olan verileri çekmek istediğinizi anlıyorum? Doğru mu?

Eğer durum böyleyse iki dosya arasında 2 sütun fark var. Nasıl bir aktarım sonucu bekliyorsunuz?

 

[KARTAL133]

Merhaba Hocam


İki excelde aynı şekikde yapılacak kapalı dosyada "No" olanlar çekecem ilk söykediğim gibi ancak sütünlarıda aynı olacak her ikisinde

 

[Korhan Ayhan]

O zaman şöyle yapalım. Siz dosyalarınızı yeniden paylaşın. Buradaki verileri buraya aktarılacak şeklinde yönlendirin. Ona göre cevap verelim.

 

[KARTAL133]

Merhaba @Korhan Ayhan Hocam

Açık kapalı Dosya ektedir. Kapalı dosyadan Sadece Açık Dosyaya "No" olanlar gelmesini için yardımlarınız rica ediyorum.

 

[Korhan Ayhan]

Deneyiniz.

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
  
    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 = 'No'")
  
    Range("A2").CopyFromRecordset My_Recordset
  
    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