Bütün excel dosyalarını alt alta ekleme

[orkunozbudak]

Herkese merhaba elimde birden fazla excel çalışma sayfası var ve bunların içinde özelliklerine göre DATA ve KOMAX olarak ayrılmıştır.Benim yapmak istediğin seçtiğim klasörün içindeki bütün excellerin datalarını ve komaxlarını ayrı olarak alt alta eklemek.Datalardaki ve Komaxtaki sutun dizilişi aynı örnek dosyaları ekliyorum.Şimdiden Teşekkür ediyorum.Açıklayamadıysamda belirtirseniz sevinirim

 

[orkunozbudak]

GÜNCEL

 

[Korhan Ayhan]

Yönlendirme yaparak destek olmak istedim..

İnceleyiniz.

Arama Sonuçları

 

[orkunozbudak]

Yönlendirme yaparak destek olmak istedim..

İnceleyiniz.

Arama Sonuçları

AYNI FORMATTAKİ DOSYALARI TEK DOSYADA BİRLEŞTİRME | Excel WEB TR Forum - Excel, Excel Makro, Excel Fonksiyon, Excel Formül, Excel soru ve çözümleri bu lınktekı dosya ısıme yarıyor fakat bazı kablo numaraların onundekı sıfırları almamıs vede nokta olan örnek 5369.4 olan kablo noyu 5369,4 yazmıs virgülleri değiştirden duzeltırım sorun yok ama o baştaki sıfırı almamasına halledebilirmiyiz birşekilde

 

[Necdet]

Merhaba,
Beyin jimnastiği olsun diye üzerinde çalışmıştım.
Dosyadaki kodları inceleyebilirsiniz.
Satır aralarındaki boşlukları silmedim.

ADO'yu kullandım.

Dim Sayfalar()
Dim Adet As Integer

Public Sub Deneme()

Dim Yol As Variant

Sayfalar = Array("DATA", "KOMAX")

DizinYoluBul Yol

If Yol = "" Then Exit Sub

TumDosyalariListele Yol

MsgBox Adet & " Adet Dosya Aktarıldı....", vbInformation

End Sub

Function DizinYoluBul(ByRef DizinYolu As Variant)

Dim fd  As FileDialog

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
If fd.SelectedItems.Count > 0 Then DizinYolu = fd.SelectedItems(1)

End Function

Sub TumDosyalariListele(Yol As Variant)

    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    Set folder = fso.GetFolder(Yol)

    For Each file In folder.Files
        If fso.GetExtensionName(file) Like "xl*" Then
            DosyaVeriAl file.Path
        End If
    Next file

    ' Alt dizinleri listele
    For Each subfolder In folder.SubFolders
        If (subfolder.Attributes And 2) = 0 Then
            Debug.Print "Klasör Adı: " & subfolder.Name
        End If
    Next subfolder
    
End Sub

Sub DosyaVeriAl(DosyaAdi As String)

Dim connection As New ADODB.connection
Dim DosyaAdı As String
Dim query As String
Dim rs As New ADODB.Recordset
Dim i As Long
Dim j As Integer

On Error GoTo Devam

Adet = Adet + 1

For j = LBound(Sayfalar) To UBound(Sayfalar)

    query = "SELECT * FROM [" & Sayfalar(j) & "$A:M]"
    
    connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DosyaAdi & _
                ";Extended Properties=""Excel 12.0;HDR=Yes;"";"
                
    rs.Open query, connection
    If j = 0 Then
        i = Sayfa1.Cells(Rows.Count, "A").End(3).Row + 2
        Sayfa1.Range("A" & i).CopyFromRecordset rs
    Else
        i = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 2
        Sayfa2.Range("A" & i).CopyFromRecordset rs
    End If
Devam:
    connection.Close
Next j

End Sub

 

[orkunozbudak]

Merhaba,
Beyin jimnastiği olsun diye üzerinde çalışmıştım.
Dosyadaki kodları inceleyebilirsiniz.
Satır aralarındaki boşlukları silmedim.

ADO'yu kullandım.

Dim Sayfalar()
Dim Adet As Integer

Public Sub Deneme()

Dim Yol As Variant

Sayfalar = Array("DATA", "KOMAX")

DizinYoluBul Yol

If Yol = "" Then Exit Sub

TumDosyalariListele Yol

MsgBox Adet & " Adet Dosya Aktarıldı....", vbInformation

End Sub

Function DizinYoluBul(ByRef DizinYolu As Variant)

Dim fd  As FileDialog

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
If fd.SelectedItems.Count > 0 Then DizinYolu = fd.SelectedItems(1)

End Function

Sub TumDosyalariListele(Yol As Variant)

    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
  
    Set fso = CreateObject("Scripting.FileSystemObject")

    Set folder = fso.GetFolder(Yol)

    For Each file In folder.Files
        If fso.GetExtensionName(file) Like "xl*" Then
            DosyaVeriAl file.Path
        End If
    Next file

    ' Alt dizinleri listele
    For Each subfolder In folder.SubFolders
        If (subfolder.Attributes And 2) = 0 Then
            Debug.Print "Klasör Adı: " & subfolder.Name
        End If
    Next subfolder
  
End Sub

Sub DosyaVeriAl(DosyaAdi As String)

Dim connection As New ADODB.connection
Dim DosyaAdı As String
Dim query As String
Dim rs As New ADODB.Recordset
Dim i As Long
Dim j As Integer

On Error GoTo Devam

Adet = Adet + 1

For j = LBound(Sayfalar) To UBound(Sayfalar)

    query = "SELECT * FROM [" & Sayfalar(j) & "$A:M]"
  
    connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DosyaAdi & _
                ";Extended Properties=""Excel 12.0;HDR=Yes;"";"
              
    rs.Open query, connection
    If j = 0 Then
        i = Sayfa1.Cells(Rows.Count, "A").End(3).Row + 2
        Sayfa1.Range("A" & i).CopyFromRecordset rs
    Else
        i = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 2
        Sayfa2.Range("A" & i).CopyFromRecordset rs
    End If
Devam:
    connection.Close
Next j

End Sub

Çok teşekkür ediyorum ellerinize sağlık yanlız söyle bir sorun var bazı excel dosyaların içinde sadece data yada sadece komax var oyuzdende hata verıyor sanırım sız hepsınde 2 sı var olarak ayarladınız.birde hata verdiği varyantıda yazma sansımız varmı bu sekılde cunku 50 60 excel dosyasında tek tek bakmam lazım hangısını eklemedıgını bulmam ıcın.Satır aralarındada boşluğu kaldırma şansımız varsa çok sevinirim

 

[Necdet]

Merhaba,
O hatayı aldım bende, incelediğimde sayfanın birinin olmadığını gördüm.
O yüzden de On error goto devam satırını eklemiştim.
ve hatadan kurtulup 6 dosyayı da okumuştu.
sizde neden hata verdi anlamadım.
Devam etiketinde connection.close satırından sonra On Error goto 0 satırını ekleyin, bir de öyle deneyin.

 

[orkunozbudak]

Merhaba,
O hatayı aldım bende, incelediğimde sayfanın birinin olmadığını gördüm.
O yüzden de On error goto devam satırını eklemiştim.
ve hatadan kurtulup 6 dosyayı da okumuştu.
sizde neden hata verdi anlamadım.
Devam etiketinde connection.close satırından sonra On Error goto 0 satırını ekleyin, bir de öyle deneyin.

Çok teşekkür ederim.Boşlukları kaldırma şansımız var mı ?

 

[Necdet]

Benim mesajlarımdaki açıklamayı görmüyor musunuz?
o açıklamayı makro kaydet ile yapıp kodlara ulaşabilirsiniz.

 

[orkunozbudak]

Benim mesajlarımdaki açıklamayı görmüyor musunuz?
Ekli dosyayı görüntüle 248276Ekli dosyayı görüntüle 248276

kucuk farklı fontla yazıldıgından dıkkat etmemısım k.bakmayın imza gibi duruyor okumamıstım teşekkür ederim ilginize