• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile başka bir excelden istenen verileri alma

K

KARTAL133

Katılım
12 Şubat 2009
Mesajlar
185
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 

Ekli dosyalar

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' Alıntı:
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.
Genişletmek için tıkla ...

Yes olan Verileri aktardıktan sonra "Yes" olanlardan açık olan dosyadan silinecek
 
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.
 
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.
 
Deneyiniz.

C++: 
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
 
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
 
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.

Rich (BB code): 
If My_Data(X, 6) = "Yes" Then
 
Merhaba Hocam

Evet onu yapa biliyorum kapalı dosyadan "No" olanları almak için söyledim
 
Dediğim değişikliği yaparak denediniz mi?

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

Evet yaptım kapalı dosyaya No olanladar gidiyor
Benim istediğim kapalı dosyadan No olanlar açık dosyaya çekmek
 
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?
 
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
 
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.
 
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.
 

Ekli dosyalar

Deneyiniz.

C++: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst