Seçilen Klasör Altındaki Dosyaları Birleştirme ve Veri Alma

muratcskn2323 · 23 Eylül 2020

Arkadaşlar merhaba bir konu hakkında yardıma ihtiyacım var.
Excel de "Toplam" diye bir sayfam var buraya bir buton ekleyerek belgelerimdeki seçeceğim 2-3 tane excelin içindeki bütün sayfaları "Toplam" sayfasının bulunduğu excele çektirmek istiyorum ve çektireceğim excel sayfalarının her birinin "N1", "N2" ve "N3" hücresini "Toplam" sayfasının sırası ile "A1","B1" ve "C1" hücrelerine yazdırıp, Çekilen sayfaların "A1" ve "B1" Hücrelerini birleştirip "Toplam" sayfasının "D1" ine yazdırmak istiyorum. Her sayfa için "N1", "N2" ve "N3" sabit ancak "A1","B1","C1" ve "D1" her yeni sayfada bi alt satıra geçecek.

Böyle bir konuda yardımcı olabilecek biri varmıdır? şimdiden teşekkür ederim.

( En Kötü ihtimalle sayfa birleştirmeyi yapsam gerisini manuel de yaparım

)

Korhan Ayhan · 24 Eylül 2020

Bu işlem için bir kaç örnek dosya paylaşmalısınız.

Toplam sayfasını içeren örnek
Veri alınacak 2-3 örnek dosya

muratcskn2323 · 24 Eylül 2020

Korhan bey merhaba
exceller i google drive yükledim umarım paylaşabilmişimdir. şimdiden çok teşekkürler. Yardımcı olabilecek arkadaş var ise mail olarak da aktarabilirim

Korhan Ayhan · 24 Eylül 2020

Dosyaları seçerek mi işlem yapmak istiyorsunuz? Yoksa veri alınacak dosyalarınız sabit bir yolda mı?

Yani butona tıkladığınızda "Lütfen işlem yapmak istediğiniz excel dosyalarını seçiniz." gibi bir özellik olsun mu? Yoksa örneğin veri alınacak dosyalarınız masaüstü gibi sabit bir yerde klasör yolu sabitlenebilir.

muratcskn2323 · 24 Eylül 2020

Korhan Ayhan' Alıntı:
Dosyaları seçerek mi işlem yapmak istiyorsunuz? Yoksa veri alınacak dosyalarınız sabit bir yolda mı?

Yani butona tıkladığınızda "Lütfen işlem yapmak istediğiniz excel dosyalarını seçiniz." gibi bir özellik olsun mu? Yoksa örneğin veri alınacak dosyalarınız masaüstü gibi sabit bir yerde klasör yolu sabitlenebilir.

Dosyaları seçerek işlem yapması çok daha makbul olabilir korhan bey. ayrıca birleştirme için ayrı bir buton. birleştirdikten sonra eklediği sayfaların bilgilerini toplam sayfasına aktarmak için ayrı buton da olabilir hangisi kolay olabilecekse

Korhan Ayhan · 24 Eylül 2020

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String
    Dim S1 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
    
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
    
    S1.Range("A:D").Clear
    Satir = 1
    
    For Each Dosya In Excel_Dosyalari
        Sutun = 1
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
            
            Sorgu = "Select F1,F14 From [Ayrım$A1:N3]"
            
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(0)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(0)
                    End If
                    If Sutun = 3 Then
                        S1.Cells(Satir, Sutun) = Kayit_Seti(1)
                        S1.Cells(Satir, Sutun + 1) = Metin
                        Metin = ""
                    Else
                        S1.Cells(Satir, Sutun) = Kayit_Seti(1)
                    End If
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                Loop
                Satir = Satir + 1
            End If
            
            Kayit_Seti.Close
            
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

muratcskn2323 · 24 Eylül 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String
    Dim S1 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
   
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
   
    S1.Range("A:D").Clear
    Satir = 1
   
    For Each Dosya In Excel_Dosyalari
        Sutun = 1
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
           
            Sorgu = "Select F1,F14 From [Ayrım$A1:N3]"
           
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(0)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(0)
                    End If
                    If Sutun = 3 Then
                        S1.Cells(Satir, Sutun) = Kayit_Seti(1)
                        S1.Cells(Satir, Sutun + 1) = Metin
                        Metin = ""
                    Else
                        S1.Cells(Satir, Sutun) = Kayit_Seti(1)
                    End If
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                Loop
                Satir = Satir + 1
            End If
           
            Kayit_Seti.Close
           
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan bey çok teşekkür ederim çalışıyor sadece 1 şey kalmış seçtiğim dosyların sayfalarını toplamın bulunduğu excelin içine aktarmıyor sadece. haricinde çok güzel çalışmış elinize emeğinize sağlık

Korhan Ayhan · 24 Eylül 2020

Kodu "Toplam" sayfasını içeren excel dosyanızda çalıştırmalısınız.

muratcskn2323 · 24 Eylül 2020

Korhan Ayhan' Alıntı:
Kodu "Toplam" sayfasını içeren excel dosyanızda çalıştırmalısınız.

Dediğiniz gibi çalıştırdım işlem yapıyor sorun yok sadece dosya1-dosya2... sayfalarını toplamın bulunduğu excele çektirmiyor. birde bu başlıkları çektirdiği A1-A2-A3 leri B1-B2-B3 yapma şansımız var mı onları hatalı yazmışım da

Korhan Ayhan · 24 Eylül 2020

Nasıl bir sonuç istiyorsanız örnek dosyanız üzerinde tarif ediniz ve paylaşınız.

muratcskn2323 · 24 Eylül 2020

Yeni excel Korhan bey güncel halini ekledim Toplam sayfasına notlar da ekledim

Korhan Ayhan · 24 Eylül 2020

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String, Sayfa As Worksheet
    Dim S1 As Worksheet, S2 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
   
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
   
    Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    Application.DisplayAlerts = True
   
    S1.Range("A2:D" & S1.Rows.Count).Clear
    Satir = 2
   
    For Each Dosya In Excel_Dosyalari
        Sutun = 2
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
           
            Sorgu = "Select * From [Ayrım$]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1

            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(0)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(0)
                    End If
                    S1.Cells(Satir, Sutun) = Kayit_Seti(12)
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                Loop
                S1.Cells(Satir, 1) = Metin
                Metin = ""
                Satir = Satir + 1
           
                Kayit_Seti.MoveFirst
           
                Set S2 = Sheets.Add(, Sheets(Sheets.Count))
                S2.Name = Left(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), 31)
                S2.Range("B1").CopyFromRecordset Kayit_Seti
            End If
           
            Kayit_Seti.Close
           
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
   
    S1.Select
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

muratcskn2323 · 24 Eylül 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String, Sayfa As Worksheet
    Dim S1 As Worksheet, S2 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
 
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Zaman = Timer
 
    Application.ScreenUpdating = False
 
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
 
    Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    Application.DisplayAlerts = True
 
    S1.Range("A2:D" & S1.Rows.Count).Clear
    Satir = 2
 
    For Each Dosya In Excel_Dosyalari
        Sutun = 2
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
         
            Sorgu = "Select * From [Ayrım$]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1

            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(0)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(0)
                    End If
                    S1.Cells(Satir, Sutun) = Kayit_Seti(12)
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                Loop
                S1.Cells(Satir, 1) = Metin
                Metin = ""
                Satir = Satir + 1
         
                Kayit_Seti.MoveFirst
         
                Set S2 = Sheets.Add(, Sheets(Sheets.Count))
                S2.Name = Left(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), 31)
                S2.Range("B1").CopyFromRecordset Kayit_Seti
            End If
         
            Kayit_Seti.Close
         
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
 
    S1.Select
 
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Önce çalıştı
S1.Cells(Satir, Sutun) = Kayit_Seti(12) kodunda hata verdi
neden olmuş olabilir

muratcskn2323 · 24 Eylül 2020

muratcskn2323' Alıntı:
Önce çalıştı
S1.Cells(Satir, Sutun) = Kayit_Seti(12) kodunda hata verdi
neden olmuş olabilir

daha doğrusu size attığımda çalıştı dosyanın alt tarafını doldurunca çalışmadı

Korhan Ayhan · 24 Eylül 2020

Ne yaptığınızı bilmiyorum. ADO kodları biraz hassastır. Dosyanıza özel kurguluyorum.

Bu sebeple yaptığınız işlemi görmem gerekiyor.

muratcskn2323 · 25 Eylül 2020

Korhan Ayhan' Alıntı:
Ne yaptığınızı bilmiyorum. ADO kodları biraz hassastır. Dosyanıza özel kurguluyorum.

Bu sebeple yaptığınız işlemi görmem gerekiyor.

Korhan bey tam olarak yapmak istediğim bu exceller
Sizin attığınız çalıştı hiç problem yok ki temelde istediğim veriler sadece sizin yaptığınız gibidir. ancak işin içine excelin tamamı girince çalışmaz oldu

son gönderdiğim linkteki gibi onlarca exceli birleştirmeye çalışıyorum yapı aynı ama malzeme kalemleri çok değişiyor.

Korhan Ayhan · 25 Eylül 2020

Deneyin bakalım istediğiniz sonucu verecek mi?

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String, Sayfa As Worksheet
    Dim S1 As Worksheet, S2 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
   
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
   
    Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    Application.DisplayAlerts = True
   
    S1.Range("A2:D" & S1.Rows.Count).Clear
    Satir = 2
   
    For Each Dosya In Excel_Dosyalari
        Sutun = 2
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
           
            Sorgu = "Select * From [Ayrım$]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1

            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(1)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(1)
                    End If
                    S1.Cells(Satir, Sutun) = Kayit_Seti(13)
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                    If Sutun > 4 Then Exit Do
                Loop
                S1.Cells(Satir, 1) = Metin
                Metin = ""
                Satir = Satir + 1
           
                Kayit_Seti.MoveFirst
           
                Set S2 = Sheets.Add(, Sheets(Sheets.Count))
                S2.Name = Left(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), 31)
                S2.Range("A1").CopyFromRecordset Kayit_Seti
                S2.Columns.AutoFit
            End If
           
            Kayit_Seti.Close
           
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
   
    S1.Select
    S1.Columns.AutoFit
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

muratcskn2323 · 25 Eylül 2020

Korhan Ayhan' Alıntı:

Deneyin bakalım istediğiniz sonucu verecek mi?

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Veri As Variant
    Dim Excel_Dosyalari As Variant, Dosya As Variant, Sorgu As String, Sayfa As Worksheet
    Dim S1 As Worksheet, S2 As Worksheet, Satir As Byte, Sutun As Byte, Metin As String
  
    Excel_Dosyalari = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    If IsArray(Excel_Dosyalari) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Toplam")
  
    Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    Application.DisplayAlerts = True
  
    S1.Range("A2:D" & S1.Rows.Count).Clear
    Satir = 2
  
    For Each Dosya In Excel_Dosyalari
        Sutun = 2
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
          
            Sorgu = "Select * From [Ayrım$]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1

            If Kayit_Seti.RecordCount > 0 Then
                Kayit_Seti.MoveFirst
                Do While Not Kayit_Seti.EOF
                    If Metin = "" Then
                        Metin = Kayit_Seti(1)
                    Else
                        Metin = Metin & "\" & Kayit_Seti(1)
                    End If
                    S1.Cells(Satir, Sutun) = Kayit_Seti(13)
                    Sutun = Sutun + 1
                    Kayit_Seti.MoveNext
                    If Sutun > 4 Then Exit Do
                Loop
                S1.Cells(Satir, 1) = Metin
                Metin = ""
                Satir = Satir + 1
          
                Kayit_Seti.MoveFirst
          
                Set S2 = Sheets.Add(, Sheets(Sheets.Count))
                S2.Name = Left(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), 31)
                S2.Range("A1").CopyFromRecordset Kayit_Seti
                S2.Columns.AutoFit
            End If
          
            Kayit_Seti.Close
          
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    Next
  
    S1.Select
    S1.Columns.AutoFit
  
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan bey çok güzel olmuş gerçekten ilgi, alakanız ve yardımlarınız için gerçekten çok teşekkür ederim

.

Korhan Ayhan · 25 Eylül 2020

@Necdet bey duymasın...

ilgi = alâka

Korhan Ayhan · 25 Eylül 2020

Ben hızlı olması açısından dosyaları açmadan (ADO ile) verileri almayı tercih ettim.

Aslında veriler biçimleri ile aktarılabilir. Fakat bu durumda dosyaları açmak gerekecektir.

Biçimler benim için önemli derseniz bu yönde de kod hazırlanabilir.

Seçilen Klasör Altındaki Dosyaları Birleştirme ve Veri Alma

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

muratcskn2323

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator