İki Koşullu Veri Aktarma

MrExcelMr · 22 Eylül 2021

Masaüstüne oluşturdum Korhan Bey, Kitap1

Korhan Ayhan · 22 Eylül 2021

Dosya içindeki sayfanın adı nedir?

Dosyanın uzantısı nedir?

MrExcelMr · 22 Eylül 2021

Sayfa1

Korhan Ayhan · 22 Eylül 2021

Deneyip sonucu bildirirseniz sevinirim.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Rem Makroda kullanacağımız tanımlamaları yapıyoruz.
    
    Dim S1 As Worksheet, S2 As Worksheet, Wb As Object, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object, Sh As Object
    Dim My_Reports As Object, My_Query As String, File_Folder As String
    
    Rem İşlem başlangıç zamanını tanımlıyoruz.
    Process_Time = Timer
    
    Rem Ekran hareketlerini ve hesaplama yöntemini pasif ediyoruz. Hızlı sonuç alabilmek adına bu işlemi yapıyoruz.
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
    
    Rem Makroda kullanacağımız sayfaları ve ADO nesnesini setliyoruz. Yani hafızaya kısa isimle alıyoruz.
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
      
    Rem ADO nesnesini kullanarak dosyaya bağlantı oluşturuyoruz.
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Rem ADO nesnesinde kullanacağımız sorguyu oluşturuyoruz. Bu bölüm iki sütuna göre DÜŞEYARA mantığı ile işlem yapmaktadır.
    My_Query = "Select Table_2.[Açıklama] From [" & S2.Name & "$]" & " As Table_1 " & _
               "Left Join [" & S1.Name & "$] As Table_2 " & _
               "On Table_1.[Kod No] = Table_2.[Kod No] And Table_1.[Kod] = Table_2.[Kod]"
        
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)
  
    Rem S2 sayfamızda M sütunundaki eski verileri temizledikten sonra sorgu sonucunu ilgili hücrelere aktarıyoruz. Sonrasında sütun genişliğini ayarlıyoruz.
    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
   
    Rem Aşı bilgilerini aktaracağımız klasörün adını tanımlıyoruz.
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
    
    Rem Klasörün varlığını kontrol ediyoruz. Yoksa oluştur diyoruz.
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    Rem Aşı isimlerini benzersiz şekilde liteleyen sorgumuzu oluşturuyoruz.
    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
    
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)

    Rem Sorgu sonucundaki ilk kaydı çağırıyoruz.
    My_Recordset.MoveFirst

    Rem Sorgu sonucunda oluşan aşı isimlerini döngüye alıyoruz.
    Do While My_Recordset.EOF = False
        Rem Aşı ismine ait kayıtları filtrelemek için sorgu oluşturuyoruz.
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
        
        Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
        Set My_Reports = My_Connection.Execute(My_Query)
           
        Rem Sorgu sonucu oluşan listeyi aktarmak için masaüstünde var olan Kitap1 isimli dosyayı açıyoruz.
        Set Wb = GetObject(Environ("UserProfile") & "\Desktop\Kitap1.xlsx")
        Set Sh = Wb.Sheets("Sayfa1")
    
        Rem Verileri ilgili sayfaya aktarıyoruz. Sonrasında sütun genişlikleri ayarlıyoruz.
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
        
        Rem Verilerin aktarıldığı sayfayı dosya olarak klasöre kayıt ediiyoruz.
        Wb.Application.DisplayAlerts = False
        Wb.Application.EnableEvents = False
        Wb.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Wb.Application.EnableEvents = True
        Wb.Application.DisplayAlerts = True
        Wb.Close 0
        Set Sh = Nothing
        Set Wb = Nothing
        
        Rem Sonraki aşı ismine devam ediyoruz.
        My_Recordset.MoveNext
    Loop
    
    Rem İşlem bittiği için ADO nesnesini kapatıyoruz.
    If My_Connection.State <> 0 Then My_Connection.Close

    Rem Makroya başlarken setlediğiniz sayfa aisimlerini ve ADO nesnesini hafızadan kaldırıyoruz.
    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Rem Ekran hareketlerini ve hesaplama yöntemini tekrar aktif hale getiriyoruz.
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
    
    Rem İşlemin bittiğine ilişkin kullanıcıya bilgilendirme mesajı veriyoruz.
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

MrExcelMr · 22 Eylül 2021

Korhan Bey şimdi denedim.

CSS:

Wb.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51

Bu kodda takıldı. Aynı hatayı uyarısı.

Korhan Ayhan · 22 Eylül 2021

Bunu deneyiniz.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Rem Makroda kullanacağımız tanımlamaları yapıyoruz.
    
    Dim S1 As Worksheet, S2 As Worksheet, Wb As Object, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object, XL_App As Object, Sh As Object
    Dim My_Reports As Object, My_Query As String, File_Folder As String
    
    Rem İşlem başlangıç zamanını tanımlıyoruz.
    Process_Time = Timer
    
    Rem Ekran hareketlerini ve hesaplama yöntemini pasif ediyoruz. Hızlı sonuç alabilmek adına bu işlemi yapıyoruz.
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
    
    Rem Makroda kullanacağımız sayfaları ve ADO nesnesini setliyoruz. Yani hafızaya kısa isimle alıyoruz.
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
      
    Rem ADO nesnesini kullanarak dosyaya bağlantı oluşturuyoruz.
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Rem ADO nesnesinde kullanacağımız sorguyu oluşturuyoruz. Bu bölüm iki sütuna göre DÜŞEYARA mantığı ile işlem yapmaktadır.
    My_Query = "Select Table_2.[Açıklama] From [" & S2.Name & "$]" & " As Table_1 " & _
               "Left Join [" & S1.Name & "$] As Table_2 " & _
               "On Table_1.[Kod No] = Table_2.[Kod No] And Table_1.[Kod] = Table_2.[Kod]"
        
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)
  
    Rem S2 sayfamızda M sütunundaki eski verileri temizledikten sonra sorgu sonucunu ilgili hücrelere aktarıyoruz. Sonrasında sütun genişliğini ayarlıyoruz.
    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
   
    Rem Aşı bilgilerini aktaracağımız klasörün adını tanımlıyoruz.
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
    
    Rem Klasörün varlığını kontrol ediyoruz. Yoksa oluştur diyoruz.
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    Rem Aşı isimlerini benzersiz şekilde liteleyen sorgumuzu oluşturuyoruz.
    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
    
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)

    Rem Sorgu sonucundaki ilk kaydı çağırıyoruz.
    My_Recordset.MoveFirst

    Rem Sorgu sonucunda oluşan aşı isimlerini döngüye alıyoruz.
    Do While My_Recordset.EOF = False
        Rem Aşı ismine ait kayıtları filtrelemek için sorgu oluşturuyoruz.
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
        
        Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
        Set My_Reports = My_Connection.Execute(My_Query)
           
        Rem Sorgu sonucu oluşan listeyi aktarmak için masaüstünde var olan Kitap1 isimli dosyayı açıyoruz.
        Set XL_App = CreateObject("Excel.Application")
        XL_App.Visible = False
        Set Wb = XL_App.Workbooks.Open(Environ("UserProfile") & "\Desktop\Kitap1.xlsx")
        Set Sh = Wb.Sheets("Sayfa1")
    
        Rem Verileri ilgili sayfaya aktarıyoruz. Sonrasında sütun genişlikleri ayarlıyoruz.
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
        
        Rem Verilerin aktarıldığı sayfayı dosya olarak klasöre kayıt ediiyoruz.
        Wb.Application.DisplayAlerts = False
        Wb.Application.EnableEvents = False
        Wb.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Wb.Application.EnableEvents = True
        Wb.Application.DisplayAlerts = True
        Wb.Close 0
        XL_App.Quit
        Set Sh = Nothing
        Set Wb = Nothing
        Set XL_App = Nothing
        
        Rem Sonraki aşı ismine devam ediyoruz.
        My_Recordset.MoveNext
    Loop
    
    Rem İşlem bittiği için ADO nesnesini kapatıyoruz.
    If My_Connection.State <> 0 Then My_Connection.Close

    Rem Makroya başlarken setlediğiniz sayfa aisimlerini ve ADO nesnesini hafızadan kaldırıyoruz.
    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Rem Ekran hareketlerini ve hesaplama yöntemini tekrar aktif hale getiriyoruz.
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
    
    Rem İşlemin bittiğine ilişkin kullanıcıya bilgilendirme mesajı veriyoruz.
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

MrExcelMr · 23 Eylül 2021

Korhan Bey,
Bu çalışma kitabı, diğer açık kitabı yada eklentiyle aynı adda kaydedilemez. Farklı bir ad seçin yada diğer çalışma kitabını veya eklentiyi kaydetmeden önce seçin. uyarı veriyor.

CSS:

SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51

Korhan Ayhan · 23 Eylül 2021

Bir önceki mesajımdaki kodda süre biraz uzadı.

Bu kod daha hızlı sonuç veriyor. Umarım sorunsuz çalışır.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Rem Makroda kullanacağımız tanımlamaları yapıyoruz.
    
    Dim S1 As Worksheet, S2 As Worksheet, Wb As Workbook, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object, Sh As Worksheet
    Dim My_Reports As Object, My_Query As String, File_Folder As String
    
    Rem İşlem başlangıç zamanını tanımlıyoruz.
    Process_Time = Timer
    
    Rem Ekran hareketlerini ve hesaplama yöntemini pasif ediyoruz. Hızlı sonuç alabilmek adına bu işlemi yapıyoruz.
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
    
    Rem Makroda kullanacağımız sayfaları ve ADO nesnesini setliyoruz. Yani hafızaya kısa isimle alıyoruz.
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
      
    Rem ADO nesnesini kullanarak dosyaya bağlantı oluşturuyoruz.
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Rem ADO nesnesinde kullanacağımız sorguyu oluşturuyoruz. Bu bölüm iki sütuna göre DÜŞEYARA mantığı ile işlem yapmaktadır.
    My_Query = "Select Table_2.[Açıklama] From [" & S2.Name & "$]" & " As Table_1 " & _
               "Left Join [" & S1.Name & "$] As Table_2 " & _
               "On Table_1.[Kod No] = Table_2.[Kod No] And Table_1.[Kod] = Table_2.[Kod]"
        
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)
  
    Rem S2 sayfamızda M sütunundaki eski verileri temizledikten sonra sorgu sonucunu ilgili hücrelere aktarıyoruz. Sonrasında sütun genişliğini ayarlıyoruz.
    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
   
    Rem Aşı bilgilerini aktaracağımız klasörün adını tanımlıyoruz.
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
    
    Rem Klasörün varlığını kontrol ediyoruz. Yoksa oluştur diyoruz.
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    Rem Aşı isimlerini benzersiz şekilde liteleyen sorgumuzu oluşturuyoruz.
    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
    
    Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
    Set My_Recordset = My_Connection.Execute(My_Query)

    Rem Sorgu sonucundaki ilk kaydı çağırıyoruz.
    My_Recordset.MoveFirst

    Rem Sorgu sonucunda oluşan aşı isimlerini döngüye alıyoruz.
    Do While My_Recordset.EOF = False
        Rem Aşı ismine ait kayıtları filtrelemek için sorgu oluşturuyoruz.
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
        
        Rem Hazırladığımız sorgumuzu çalıştırıyoruz.
        Set My_Reports = My_Connection.Execute(My_Query)
           
        Rem Sorgu sonucu oluşan listeyi aktarmak için masaüstünde var olan Kitap1 isimli dosyayı açıyoruz.
        Set Wb = Workbooks.Add(1)
        Set Sh = Wb.Sheets(1)
    
        Rem Verileri ilgili sayfaya aktarıyoruz. Sonrasında sütun genişlikleri ayarlıyoruz.
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
        
        Rem Verilerin aktarıldığı sayfayı dosya olarak klasöre kayıt ediiyoruz.
        Wb.Application.DisplayAlerts = False
        Wb.Application.EnableEvents = False
        Wb.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Wb.Application.EnableEvents = True
        Wb.Application.DisplayAlerts = True
        Wb.Close 0
        Set Sh = Nothing
        Set Wb = Nothing
        
        Rem Sonraki aşı ismine devam ediyoruz.
        My_Recordset.MoveNext
    Loop
    
    Rem İşlem bittiği için ADO nesnesini kapatıyoruz.
    If My_Connection.State <> 0 Then My_Connection.Close

    Rem Makroya başlarken setlediğiniz sayfa aisimlerini ve ADO nesnesini hafızadan kaldırıyoruz.
    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Rem Ekran hareketlerini ve hesaplama yöntemini tekrar aktif hale getiriyoruz.
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
    
    Rem İşlemin bittiğine ilişkin kullanıcıya bilgilendirme mesajı veriyoruz.
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

MrExcelMr · 23 Eylül 2021

Korhan Bey,
Çok teşekkür ederim. Sorun çözümüştür. Sadece 50.000 üzeri veride yaklaşık olarak 1 dk geçiyor.
TİTUS belasından kurtulduk. Desteğiniz için çok teşekkür ederim.

Korhan Ayhan · 23 Eylül 2021

Eğer @Ziynettin beyin önerisi daha hızlı sonuç veriyorsa onu kullanın.

MrExcelMr · 23 Eylül 2021

Korhan Bey, Ziynettin Bey,
Teşekkür ederim. Kolaylıklar dilerim sizlere....

Korhan Ayhan · 23 Eylül 2021

Şimdi verileri 60.000 satıra kadar çoğaltıp test yaptım.

Benim önerdiğim ADO örneği ; 7,35 Saniye civarında sürdü.

Ziynettin beyi önerisi ; 3,44 Saniye civarında sürdü.

Yalnız bir açıklama yapmak isterim. Benim önerdiğim kod önce Data sayfasındaki boş olan M sütununa verileri aktardıktan sonra bu sürede işlemi tamamlıyor. Ziynettin beyin önerisinde ise M sütunu doluyken işlemi yaptığı için daha hızlı sonuç veriyor gibi görünüyor.

İki Koşullu Veri Aktarma

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator