Kapalı Excel dosyalarından veri alarak veritabanı oluşturma

ongbey · 20 Kasım 2018

Merhabalar, amacım elimdeki mevcut tüm Excel dosyalarını kontrol ederek, B10 hücresinin "Current" olması durumunda, o dosyadaki B, C ve F kolonundaki verileri sırası ile "Veri tabanı.xlsx " dosyasına verilen örnekteki düzende almaktır. Veriler 12. satırdan başlıyor ve maks 14 adet olabiliyor. Verileri aldıktan sonra dosya kapatılacak. Bu şekilde bir kaç yüz dosyam var. Yardımcı olursanız çok sevinirim. Sanıyorum ki bu iş SQL komutları ile olmuyor çünkü dosyadaki veriler veritabanı formunda değil. Ben de başka bir yol bulamadığımdan sizlerden yardım talep ediyorum.

Erdem Akdemir · 20 Kasım 2018

Merhaba,

Dosyaları Zip'li olarak eklemeniz daha iyi olur.

ongbey · 20 Kasım 2018

Teşekkürler, değiştirdim.

turist · 20 Kasım 2018

Dosyanız eklidir.(Sıkıştırılmış dosyadır, içindeki klasörü bilgisayarınızda uygun bir yere çıkartınız)
"MOTOR VERİ TABANI" isimli klasörde bütün dosyalar yer almaktadır.
Sadece Veritabanı.xlsm dosyasını açarak

Korhan Ayhan · 21 Kasım 2018

Alternatif;

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim Klasor As Object, Dosya_Yolu As String, Dosyalar As Object, Dosya As Object
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Satir As Long
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir Klasor seçin !", &H100)

    If Not Klasor Is Nothing Then
        Dosya_Yolu = Klasor.Self.Path & "\"
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız !", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Range("A2:AQ" & Rows.Count).ClearContents
    Range("A2:AQ" & Rows.Count).Borders.LineStyle = False
    Satir = 2
    
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
 
    For Each Dosya In Dosyalar
        If InStr(Dosya.Type, "Excel") > 0 Then
            If InStr(1, Dosya.Name, ThisWorkbook.Name) = 0 Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya.Path & ";Extended Properties=""Excel 12.0;Hdr=No"""
                
                Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B10:B10]")
                If Kayit_Seti.Fields.Item(0).Value = "Current" Then
                    Cells(Satir, 1) = Dosya.Name
                    
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B12:B25]")
                    Range("B" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                    
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$C12:C25]")
                    Range("P" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$F12:F25]")
                    Range("AD" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                    
                    Satir = Satir + 1
                End If
                
                Kayit_Seti.Close
                Baglanti.Close
            End If
        End If
    Next
    
    Cells.Font.Name = "Calibri"
    Cells.Font.Size = 11
    
    Range("A2:AQ" & Satir - 1).Borders.LineStyle = 1
    Range("A:AQ").EntireColumn.AutoFit
    
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

ongbey · 21 Kasım 2018

turist' Alıntı:
Dosyanız eklidir.(Sıkıştırılmış dosyadır, içindeki klasörü bilgisayarınızda uygun bir yere çıkartınız)
"MOTOR VERİ TABANI" isimli klasörde bütün dosyalar yer almaktadır.
Sadece Veritabanı.xlsm dosyasını açarak

Hocam kod mükemmel çalışıyor, elinize sağlık. Biraz inceleyip nasıl çalıştığını çözmeye çalışacağım. Teşekkürler.

ongbey · 21 Kasım 2018

Korhan Ayhan' Alıntı:

Alternatif;

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim Klasor As Object, Dosya_Yolu As String, Dosyalar As Object, Dosya As Object
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Satir As Long
       
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set Baglanti = CreateObject("AdoDb.Connection")
   
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir Klasor seçin !", &H100)

    If Not Klasor Is Nothing Then
        Dosya_Yolu = Klasor.Self.Path & "\"
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız !", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Range("A2:AQ" & Rows.Count).ClearContents
    Range("A2:AQ" & Rows.Count).Borders.LineStyle = False
    Satir = 2
   
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files

    For Each Dosya In Dosyalar
        If InStr(Dosya.Type, "Excel") > 0 Then
            If InStr(1, Dosya.Name, ThisWorkbook.Name) = 0 Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya.Path & ";Extended Properties=""Excel 12.0;Hdr=No"""
               
                Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B10:B10]")
                If Kayit_Seti.Fields.Item(0).Value = "Current" Then
                    Cells(Satir, 1) = Dosya.Name
                   
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B12:B25]")
                    Range("B" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                   
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$C12:C25]")
                    Range("P" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
               
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$F12:F25]")
                    Range("AD" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                   
                    Satir = Satir + 1
                End If
               
                Kayit_Seti.Close
                Baglanti.Close
            End If
        End If
    Next
   
    Cells.Font.Name = "Calibri"
    Cells.Font.Size = 11
   
    Range("A2:AQ" & Satir - 1).Borders.LineStyle = 1
    Range("A:AQ").EntireColumn.AutoFit
   
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

Hocam sizin kod da güzel ve belki diğer koda göre hızlı çalışıyor ama sanıyorum ki folder' da kontrol kriterine uygun olmayan bir dosya ile karlıaştığında error veriyor. Verdiği hata mesajı "Bu tablo bu elektronik tabloda tanımlı hücre aralıklarının dışında olan hücreler hatası". Ekran görüntüsünü ekledim. Bir bakar mısınız ?

Haluk · 21 Kasım 2018

ongbey' Alıntı:
Hocam sizin kod da güzel ve belki diğer koda göre hızlı çalışıyor ama sanıyorum ki folder' da kontrol kriterine uygun olmayan bir dosya ile karlıaştığında error veriyor. Verdiği hata mesajı "Bu tablo bu elektronik tabloda tanımlı hücre aralıklarının dışında olan hücreler hatası". Ekran görüntüsünü ekledim. Bir bakar mısınız ?

Korhan Beyin kodunda bir problem yok.

Sizin dikkat etmeniz gereken tek konu; klasörde Veri Tabanı.xlsm ve diğer Motor1-2-3.xlsx dosyalarının haricinde başka bir dosya olmayacak. Örneğin; klasörde hem Veri Tabanı.xlsx hem de Veri Tabanı.xlsm olursa, problem çıkar.

.

ongbey · 21 Kasım 2018

Haluk' Alıntı:
Korhan Beyin kodunda bir problem yok.

Sizin dikkat etmeniz gereken tek konu; klasörde Veri Tabanı.xlsm ve diğer Motor1-2-3.xlsx dosyalarının haricinde başka bir dosya olmayacak. Örneğin; klasörde hem Veri Tabanı.xlsx hem de Veri Tabanı.xlsm olursa, problem çıkar.

.

Tekrar denedim, kod ışık hızı ile çalışıyor, mükemmel. Fakat folder' da sadece aynı formatta dosyalar olması gerekiyor. Yani xlss yada xlsm farketmiyor. Farklı formatta hata veriyor.

ongbey · 21 Kasım 2018

turist' Alıntı:
Dosyanız eklidir.(Sıkıştırılmış dosyadır, içindeki klasörü bilgisayarınızda uygun bir yere çıkartınız)
"MOTOR VERİ TABANI" isimli klasörde bütün dosyalar yer almaktadır.
Sadece Veritabanı.xlsm dosyasını açarak

Programın veri alması için B10 hücresinin "Current" olması koşulu vardı. Kodunuzda böyle bir kontrol olmasına rağmen, klasörde bu koşulu karşılamayan dosyalardan da veri alıyor. Bu durumu kontrol edebilir misiniz?

Korhan Ayhan · 22 Kasım 2018

Merhaba,

Excel 2019 versiyonda aşağıdaki kodu denedim. Klasör içinde "xls" "xlsx" "xlsm" "xlsb" formatlarında dosyalar oluşturdum. Denemelerimde hepsindeki veriyi "Current" koşuluna bakarak aktardı.

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim Klasor As Object, Dosya_Yolu As String, Dosyalar As Object, Dosya As Object
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Satir As Long
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir Klasor seçin !", &H100)

    If Not Klasor Is Nothing Then
        Dosya_Yolu = Klasor.Self.Path & "\"
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız !", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Range("A2:AQ" & Rows.Count).ClearContents
    Range("A2:AQ" & Rows.Count).Borders.LineStyle = False
    Satir = 2
    
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
 
    For Each Dosya In Dosyalar
        If InStr(Dosya.Type, "Excel") > 0 Then
            If Dosya.Name <> ThisWorkbook.Name And Left(Dosya.Name, 2) <> "~$" Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya.Path & ";Extended Properties=""Excel 12.0;Hdr=No"""
                
                Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B10:B10]")
                If Kayit_Seti.Fields.Item(0).Value = "Current" Then
                    Cells(Satir, 1) = Dosya.Name
                    
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B12:B25]")
                    Range("B" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                    
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$C12:C25]")
                    Range("P" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$F12:F25]")
                    Range("AD" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                    
                    Satir = Satir + 1
                End If
                
                Kayit_Seti.Close
                Baglanti.Close
            End If
        End If
    Next
    
    Cells.Font.Name = "Calibri"
    Cells.Font.Size = 11
    
    Range("A2:AQ" & Satir - 1).Borders.LineStyle = 1
    Range("A:AQ").EntireColumn.AutoFit
    
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

turist · 22 Kasım 2018

ongbey' Alıntı:
Programın veri alması için B10 hücresinin "Current" olması koşulu vardı. Kodunuzda böyle bir kontrol olmasına rağmen, klasörde bu koşulu karşılamayan dosyalardan da veri alıyor. Bu durumu kontrol edebilir misiniz?

Kodun aşağıdaki bölümünde

If Dosyaismi <> ThisWorkbook.Name Then
Set Kitap = Workbooks.Open(Yol & Dosyaismi)
LR = Worksheets("Sayfa1").Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & NR) = Dosyaismi
Worksheets("Sayfa1").Range("B12:B" & LR).Copy
.Range("B" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("C12:C" & LR).Copy
.Range("P" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("F12:F" & LR).Copy
.Range("AD" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Kitap.Close False
Set Kitap = Workbooks.Open(Yol & Dosyaismi)

yazan alanda

If Dosyaismi <> ThisWorkbook.Name Then
Set Kitap = Workbooks.Open(Yol & Dosyaismi)
If ActiveSheet.Range("B10") = "Current" Then
LR = Worksheets("Sayfa1").Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & NR) = Dosyaismi
Worksheets("Sayfa1").Range("B12:B" & LR).Copy
.Range("B" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("C12:C" & LR).Copy
.Range("P" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("F12:F" & LR).Copy
.Range("AD" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Kitap.Close False
şeklinde revize ederek deneyin.

ongbey · 22 Kasım 2018

Korhan Ayhan' Alıntı:

Merhaba,

Excel 2019 versiyonda aşağıdaki kodu denedim. Klasör içinde "xls" "xlsx" "xlsm" "xlsb" formatlarında dosyalar oluşturdum. Denemelerimde hepsindeki veriyi "Current" koşuluna bakarak aktardı.

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim Klasor As Object, Dosya_Yolu As String, Dosyalar As Object, Dosya As Object
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Satir As Long
       
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set Baglanti = CreateObject("AdoDb.Connection")
   
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir Klasor seçin !", &H100)

    If Not Klasor Is Nothing Then
        Dosya_Yolu = Klasor.Self.Path & "\"
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız !", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Range("A2:AQ" & Rows.Count).ClearContents
    Range("A2:AQ" & Rows.Count).Borders.LineStyle = False
    Satir = 2
   
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files

    For Each Dosya In Dosyalar
        If InStr(Dosya.Type, "Excel") > 0 Then
            If Dosya.Name <> ThisWorkbook.Name And Left(Dosya.Name, 2) <> "~$" Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya.Path & ";Extended Properties=""Excel 12.0;Hdr=No"""
               
                Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B10:B10]")
                If Kayit_Seti.Fields.Item(0).Value = "Current" Then
                    Cells(Satir, 1) = Dosya.Name
                   
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$B12:B25]")
                    Range("B" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                   
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$C12:C25]")
                    Range("P" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
               
                    Set Kayit_Seti = Baglanti.Execute("Select * From [Sayfa1$F12:F25]")
                    Range("AD" & Satir).Resize(1, 14) = Kayit_Seti.GetRows
                   
                    Satir = Satir + 1
                End If
               
                Kayit_Seti.Close
                Baglanti.Close
            End If
        End If
    Next
   
    Cells.Font.Name = "Calibri"
    Cells.Font.Size = 11
   
    Range("A2:AQ" & Satir - 1).Borders.LineStyle = 1
    Range("A:AQ").EntireColumn.AutoFit
   
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

Çok teşekürler, işe yaradı.

ongbey · 22 Kasım 2018

turist' Alıntı:
Kodun aşağıdaki bölümünde

If Dosyaismi <> ThisWorkbook.Name Then
Set Kitap = Workbooks.Open(Yol & Dosyaismi)
LR = Worksheets("Sayfa1").Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & NR) = Dosyaismi
Worksheets("Sayfa1").Range("B12:B" & LR).Copy
.Range("B" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("C12:C" & LR).Copy
.Range("P" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("F12:F" & LR).Copy
.Range("AD" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Kitap.Close False
Set Kitap = Workbooks.Open(Yol & Dosyaismi)

yazan alanda

If Dosyaismi <> ThisWorkbook.Name Then
Set Kitap = Workbooks.Open(Yol & Dosyaismi)
If ActiveSheet.Range("B10") = "Current" Then
LR = Worksheets("Sayfa1").Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & NR) = Dosyaismi
Worksheets("Sayfa1").Range("B12:B" & LR).Copy
.Range("B" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("C12:C" & LR).Copy
.Range("P" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Sayfa1").Range("F12:F" & LR).Copy
.Range("AD" & NR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Kitap.Close False
şeklinde revize ederek deneyin.

Hocam çok teşekkürler, emeğinize sağlık.

turist · 22 Kasım 2018

ongbey' Alıntı:
Hocam çok teşekkürler, emeğinize sağlık.

Sağ olun, iyi çalışmalar.

Kapalı Excel dosyalarından veri alarak veritabanı oluşturma

ongbey

Ekli dosyalar

Erdem Akdemir

Destek Ekibi

ongbey

turist

Destek Ekibi

Ekli dosyalar

Korhan Ayhan

Administrator

ongbey

ongbey

Ekli dosyalar

Haluk

Özel Üye

ongbey

ongbey

Korhan Ayhan

Administrator

turist

Destek Ekibi

ongbey

ongbey

turist

Destek Ekibi