İki Koşullu Veri Aktarma

ÖmerFaruk · 9 Eylül 2021

MrExcelMr' Alıntı:
@ÖmerFaruk @Korhan Ayhan @Ziynettin Beyler çok teşekkür ederiz. Emeğine sağlık.

@ÖmerFaruk Bey Korhan beyin vermiş olduğu bilgilere göre koddun revize halini paylaşma şansınız olur mu.

Çok basit 2 satıra 2 ilaveyi sizler yapmaya çalışmalı ve yaptıkça emek verdikçe daha hızlı kavrayacaksınız.
Sadece öneri.

C++:

Sub Açıklama2()
Dim Bul As Range, i As Long, k As Long, x as lonng
Dim AraList(), KodList(), NList()
Dim Zaman As Double
    Zaman = Timer
    AraList = Range("F2:G" & Range("F1").End(4).Row).Value
    KodList = Sheets("Kodlar").Range("A2:C" & Sheets("Kodlar").Range("A1").End(4).Row).Value
    ReDim NList(1 To UBound(AraList, 1), 1 To 1)
  
    For i = LBound(AraList, 1) To UBound(AraList, 1)
        For k = LBound(KodList, 1) To UBound(KodList, 1)
            If KodList(k, 1) = AraList(i, 1) And KodList(k, 2) = AraList(i, 2) Then
                x = x + 1
                NList(x,1) = KodList(k, 3)
                Exit For
            End If
        Next k
    Next i
    Range("M2:M" & Range("F1").End(4).Row) = NList
    MsgBox "Toplam Süre : " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

MrExcelMr · 9 Eylül 2021

Merhaba,
#19 mesajdaki talep için destek olabilir misiniz.

TaylanYüksek · 10 Eylül 2021

Macro formülü istemişsiniz ama 2 sayfaya da yardımcı bir sütun yaratarak basit bir vlookup veya index-match ile de 2 koşullu veri getirilebilir diye düşünüyorum. Tek bir sütuna bakacağı için performans açısından daha verimli çalışacaktır.
Linkteki excelde örneğimi ilettim.

MrExcelMr · 10 Eylül 2021

@TaylanYüksek Bey makro ile yapmazsan formülle yapabiliyoruz. Fakat çok yavaş çalışıyor. Bu yüzden makro talebimiz oldu. Şimdi ise verileri alıyoruz ama toplu olduğu için ram den kaynaklı sıkıntı yaşıyoruz. #19 nolu mesajda belirtmiş olduğum talebimiz ordaya çıktı.

ÖmerFaruk · 10 Eylül 2021

MrExcelMr' Alıntı:
@ÖmerFaruk @Korhan Ayhan @Ziynettin değerli uzmanlar,
Data Sayfasındaki M sutundaki verileri yeni bir tuşa atayarak aynı olan aşı bilgilerini "A-M" sütunundaki başlıklar ve değerler ile bilgilerini yeni kitap halinde "Biontech5, Biontech6"gibi klasörün içerisine filtreleme imkanımız olur mu? İnşallah tarif edebilmişimdir.

Anlamadım ne demeye çalıştığınızı.

Şu mudur?
Konunun başında 100 adet KOD yad acivarında olacağınız söylemiştiniz.
Haliyle M sütununda 100 defa süzme yapılıp sadece tek bir aşı türünden verileri içeren 100 yeni excel kitabımı oluştutracaksınız.

MrExcelMr · 11 Eylül 2021

ÖmerFaruk' Alıntı:
Anlamadım ne demeye çalıştığınızı.

Şu mudur?
Konunun başında 100 adet KOD yad acivarında olacağınız söylemiştiniz.
Haliyle M sütununda 100 defa süzme yapılıp sadece tek bir aşı türünden verileri içeren 100 yeni excel kitabımı oluştutracaksınız.

Ömer Faruk Bey,
M sütununda 50 adet farklı Açıklama bilgileri geliyor. Süzmek için filtreleme yaptığımda donma yapıyor. Bende çözüm olarak Masaüstüne bir klasör açıp, Başlıklar ve A ile M sütununa arasındaki veriler ile birlikte kitap olarak farklı dosyalar halinde excel oluşturmak istedim. Tek bir aşı türünden kaç adet var ise, hepsini aynı çalışma kitabı içine aktarmasını istiyorum.

Biontech1 leri bir kitaba, Biontech4 bir kitaba bu şekilde çalışma yapmak istediğim aşı bilgilerine ulaşmış olacağım.

Ziynettin · 11 Eylül 2021

"Karsilastirma" dosyanız bulunduğu yolda ASILAR klasörü ve bu klasör içine excel dosyalarını aktarır.

Kod:

Sub klasor_dosya_Olustur()
Dim Yol As String, s1 As Worksheet

Set s1 = Sheets("Data")
Set dc = CreateObject("scripting.dictionary")

son = s1.Range("M" & Rows.Count).End(3).Row
If son < 2 Then Exit Sub

    a = s1.Range("A1:M" & son).Value
    
    For i = 2 To UBound(a)
        If a(i, 13) <> "" Then dc(a(i, 13)) = ""
    Next i

    kls = "ASILAR"
    Yol = ThisWorkbook.Path & "\" & kls & ""
    Set ds = CreateObject("Scripting.FileSystemObject")
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    If ds.FolderExists(Yol) Then ds.DeleteFolder Yol
    If Not ds.FolderExists(Yol) Then ds.CreateFolder Yol
    
    If dc.Count > 0 Then
        sh = dc.keys
        For j = 0 To dc.Count - 1
            ReDim b(1 To UBound(a), 1 To 13)
            Workbooks.Add
            ActiveWorkbook.ActiveSheet.Name = sh(j)
            For i = 2 To UBound(a)
                If a(i, 13) = sh(j) Then
                    say = say + 1
                    For y = 1 To UBound(a, 2)
                        b(say, y) = a(i, y)
                    Next y
                End If
            Next i
            If say > 0 Then
                s1.[A1:M1].Copy ActiveWorkbook.ActiveSheet.Range("A1")
                ActiveWorkbook.ActiveSheet.Range("A2").Resize(say, 13) = b
                ActiveWorkbook.ActiveSheet.Range("A1").Resize(say + 1, 13).Borders.Color = rgbSilver
                ActiveWindow.DisplayGridlines = False
            End If
            say = 0
            ActiveWorkbook.SaveAs Filename:=Yol & "\" & sh(j), FileFormat:=51, _
                                            Local:=True, CreateBackup:=False
            
            ActiveWorkbook.Close 0
            
        Next j
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
MsgBox "İşlem tamam.", vbInformation

MrExcelMr · 11 Eylül 2021

@Ziynettin Bey bizi çok büyük bir dertten kurtardınız. Çok teşekkür ederim. Sağlıcakla...

Korhan Ayhan · 11 Eylül 2021

Alternatif;

Hız performansı olarak biraz daha iyi sonuç verecektir.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Dim S1 As Worksheet, S2 As Worksheet, 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
  
    Process_Time = Timer
  
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
  
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    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]"
      
    Set My_Recordset = My_Connection.Execute(My_Query)

    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
 
  
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
  
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
  
    Set My_Recordset = My_Connection.Execute(My_Query)

    My_Recordset.MoveFirst

    Do While My_Recordset.EOF = False
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
      
        Set My_Reports = My_Connection.Execute(My_Query)
         
        Set Sh = CreateObject("Excel.Sheet")
  
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
      
        Sh.Application.DisplayAlerts = False
        Sh.Application..EnableEvents = False
        Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Sh.Application..EnableEvents = True
        Sh.Application.DisplayAlerts = True
        Sh.Close
        Set Sh = Nothing
      
        My_Recordset.MoveNext
    Loop
  
    If My_Connection.State <> 0 Then My_Connection.Close

    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
  
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
  
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

MrExcelMr · 11 Eylül 2021

@Korhan Ayhan Bey teşekkür ederim.

MrExcelMr · 11 Eylül 2021

Korhan Ayhan' Alıntı:

Alternatif;

Hız performansı olarak biraz daha iyi sonuç verecektir.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Dim S1 As Worksheet, S2 As Worksheet, 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
 
    Process_Time = Timer
 
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
 
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
   
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    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]"
     
    Set My_Recordset = My_Connection.Execute(My_Query)

    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With

 
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
 
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
 
    Set My_Recordset = My_Connection.Execute(My_Query)

    My_Recordset.MoveFirst

    Do While My_Recordset.EOF = False
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
     
        Set My_Reports = My_Connection.Execute(My_Query)
        
        Set Sh = CreateObject("Excel.Sheet")
 
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
     
        Sh.Application.DisplayAlerts = False
        Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Sh.Application.DisplayAlerts = True
        Sh.Close
        Set Sh = Nothing
     
        My_Recordset.MoveNext
    Loop
 
    If My_Connection.State <> 0 Then My_Connection.Close

    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
 
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

Korhan Bey Mümkünse ve vaktiniz var ise, Yazmış olduğunuz kodu açıklamayabilir misiniz. Hangi kod ne işlevi yapıyor.
Hastane de bu ve bu konuya benzer işlevler yapıyoruz. Öğrenmek hemde gerekli güncellemeleri yapabilmek açısından öğretici olacaktır. Teşekkürler.

Korhan Ayhan · 11 Eylül 2021

Kod içine kısa notlar ekledim. Sanırım sizi yönlendirecektir.

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, 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 boş bir excel sayfası oluşturuyoruz.
        Set Sh = CreateObject("Excel.Sheet")
    
        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.
        Sh.Application.DisplayAlerts = False
        Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Sh.Application.DisplayAlerts = True
        Sh.Close
        Set Sh = 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 · 12 Eylül 2021

Korhan Bey.
Çok teşekkür ederim. Vakit ayırıp bu güzel paylaşımı hazırladığınız için...

MrExcelMr · 12 Eylül 2021

CSS:

    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]"

 .Range("N2:M" & .Rows.Count).ClearContents
N2:M her iki sütununa ait değerlerin silinmesini mi anlamalıyım.

Korhan Bey buradaki mantığı anlatabilir misiniz.

Korhan Ayhan · 12 Eylül 2021

.Range("N2:M" & .Rows.Count).ClearContents bold bölümü ben hatalı yazmışım. Gözler biraz bozuk olunca M harfi yazdığımı zannetmişim. Kodlarda gerekli revizeyi yaptım.

ADO sorgusu ise iki sayfadaki tablolarda KOD NO ve KOD sütunlarını eşleştirerek AÇIKLAMA sütununu döndürmektedir.

MrExcelMr · 12 Eylül 2021

Korhan Bey ilginiz için teşekkür ederim.

MrExcelMr · 15 Eylül 2021

Korhan Ayhan' Alıntı:

Alternatif;

Hız performansı olarak biraz daha iyi sonuç verecektir.

C++:

Option Explicit

Sub Export_Data_As_File_To_Folder()
    Dim S1 As Worksheet, S2 As Worksheet, 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
  
    Process_Time = Timer
  
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
  
    Set S1 = Sheets("Kodlar")
    Set S2 = Sheets("Data")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    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]"
      
    Set My_Recordset = My_Connection.Execute(My_Query)

    With S2
        .Range("M2:M" & .Rows.Count).ClearContents
        .Range("M2").CopyFromRecordset My_Recordset
        .Columns.AutoFit
    End With
 
  
    File_Folder = Environ("UserProfile") & "\Desktop\Aşılar " & Format(Date, "dd_mm_yyyy") & "\"
  
    If Dir(File_Folder, vbDirectory) = "" Then MkDir File_Folder

    My_Query = "Select Distinct [Açıklama] From [" & S2.Name & "$] Where Not IsNull([Açıklama])"
  
    Set My_Recordset = My_Connection.Execute(My_Query)

    My_Recordset.MoveFirst

    Do While My_Recordset.EOF = False
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
      
        Set My_Reports = My_Connection.Execute(My_Query)
         
        Set Sh = CreateObject("Excel.Sheet")
  
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
      
        Sh.Application.DisplayAlerts = False
        Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51
        Sh.Application.DisplayAlerts = True
        Sh.Close
        Set Sh = Nothing
      
        My_Recordset.MoveNext
    Loop
  
    If My_Connection.State <> 0 Then My_Connection.Close

    Set My_Reports = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
  
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
  
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

Korhan Bey Merhaba,
Bir konu hakkında bilgi almak istiyorum. .
Hastanede kullandığımız bilgisayarda titus classification "veri sınıflandırma yazılımı yüklü" kodu çalıştırdığımda yeni bir kitap açılıyor. " Hastane içi" seçip Ok. basmam gerekiyor. Bunu 4 kez yaptığında bu sefer kod hata veriyor ve aktarım yarı da kalıyor. Bu hatayı atlatmak için ne yapılabilir.

Korhan Ayhan · 16 Eylül 2021

Merhaba,

Normal bir bilgisayarda denediğinizde sorun oluyor mu?

Ben bahsettiğiniz yazılımın ismini daha önce hiç duymadım. Bu sebeple bir yönlendirme yapamayacağım.

Çözüm adına kodu F8 tuşu ile adım adım çalıştırın hangi satıra geldiğinde bahsettiğiniz sorun oluşuyor bunu tespit edin. Sonrasında gerekirse alternatif çözüm arayışına gireriz.

MrExcelMr · 16 Eylül 2021

Korhan Bey,

CSS:

 Do While My_Recordset.EOF = False
        My_Query = "Select * From [" & S2.Name & "$] Where [Açıklama] = '" & My_Recordset(0) & "'"
      
        Set My_Reports = My_Connection.Execute(My_Query)
          
        Set Sh = CreateObject("Excel.Sheet")
  
        With Sh.Application
            .Range("A1:M1").Value = S2.Range("A1:M1").Value
            .Range("A2").CopyFromRecordset My_Reports
            .Columns.AutoFit
        End With
      
        Sh.Application.DisplayAlerts = False
        Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51

Kodu tek tek çalıştırdığımda üstteki kod 3 kez çalışıyor. "titus programı devreye giriyor." daha sonrasında Sh.SaveAs File_Folder & My_Recordset(0) & ".xlsx", 51 kod kalıyor.
Şu şekilde uyarı,

Run-time error '1004';
Microsoft Excel 'C:/Users/Bölüm1/Desktop/Aşılar/16.09.2021/Biontech6/FF641000' dosyasına erişemiyor. Birkaç olası neden vardır:

*Dosya adı ya da yol yok.
*Dosya başka bir program tarafından kullanılıyor.
*Kaydetmeye çalıştığınız çalışma kitabı. şu anda açık olan bir çalışma

Korhan Ayhan · 16 Eylül 2021

Sorumu tekrar edeyim.

Normal bir bilgisayarda denediğinizde sorun oluyor mu?

İki Koşullu Veri Aktarma

ÖmerFaruk

Destek Ekibi

MrExcelMr

TaylanYüksek

MrExcelMr

ÖmerFaruk

Destek Ekibi

MrExcelMr

Ziynettin

Destek Ekibi

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

MrExcelMr

Korhan Ayhan

Administrator

MrExcelMr

Korhan Ayhan

Administrator