excell dosyalarını birleştir.

[sevensuleyman]

formu araştırdım birçok örnek gördüm fakat verilerime uyarlayamadım. bu konuda yardımcı olursanız sevinirim. şimdiden teşekkürler

merhaba ; farklı klasörlerde farklı isimlerde excell dosyalarım mevcut.
içerik başlıkları aynıdır.
veriler değişkenlik göstermektedir.
seçeceğim tüm excell dosyları içerisindeki verileri alt alta birleştirmek.
burada excell dosyalarını tek tek veya çoklu seçerek içerisinde verileri tek sayfada toplamak istiyorum.
seçeceğim her excell dosyası saydaki en son verinin altına ekleyecek

sayfa temizleme işlemini manuel veya buton ile yapabiliriz.
ekde örnek dosyalarım mevcuttur.

a1 satırında sütun başlıkları mevcuttur.
veriler a2 satırından başlamktadır.

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub DosyaSec()

' Referanaslardan Microsoft ActiveX Data Objects x.x Library Seçili Olmalı
    Dim Dosyalar As Variant
    Dim Dosya As Variant

    Dosyalar = Application.GetOpenFilename("Exel Dosyaları (*.xls*), *xls*", , , , True)
    If IsArray(Dosyalar) Then  '<~~ Çoklu Seçim Yapıldıysa
        For Each Dosya In Dosyalar
            DosyaSecilenAktar Dosya
        Next Dosya
    Else '<~~ Tek Seçim Yapıldıysa
        If Dosyalar = True Then
            DosyaSecilenAktar Dosyalar
        Else
'            MsgBox "Dosya Seçilmedi.."
        End If
    End If
End Sub

Sub DosyaSecilenAktar(DosyaAdi As Variant)

    Dim Yol As String
    Dim i As Long
    Dim j As Long
    Dim cn As Object
    Dim Rs As Object
    
    Set cn = VBA.CreateObject("adodb.Connection")
    Set Rs = VBA.CreateObject("adodb.Recordset")
    
    Application.ScreenUpdating = False
    
    Yol = DosyaAdi
    i = Cells(Rows.Count, "B").End(3).Row + 1
    cn.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & Yol & _
        ";Extended Properties='Excel 12.0;HDR=YES';"

    cn.Open
    
    Rs.ActiveConnection = cn
    
    Rs.Source = "SELECT * FROM [Güncelleme Bilgileri$]"
    
    Rs.Open
    Sayfa1.Range("A" & i) = DosyaAdi
    Sayfa1.Range("B" & i).CopyFromRecordset Rs
    
    Rs.Close
    cn.Close

    Set Rs = Nothing
    Set cn = Nothing
     
    i = Cells(Rows.Count, "A").End(3).Row
    j = Cells(Rows.Count, "B").End(3).Row
    If j > i Then Range("A" & i & ":A" & j).FillDown
   
    Application.ScreenUpdating = True
    
End Sub

Sub DosyaVeriSil()

    Dim EH As String
   
    EH = MsgBox("Verileri Silmek İstediğinizden Emin Misiniz?", vbYesNo, "Silme İşlemi")
    If EH = vbYes Then
        Range("A1").CurrentRegion.Offset(1).ClearContents
    Else
        MsgBox "SİLMEKTEN VAZ GEÇTİNİZ...."
    End If
       
End Sub

 

[sevensuleyman]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub DosyaSec()

' Referanaslardan Microsoft ActiveX Data Objects x.x Library Seçili Olmalı
    Dim Dosyalar As Variant
    Dim Dosya As Variant

    Dosyalar = Application.GetOpenFilename("Exel Dosyaları (*.xls*), *xls*", , , , True)
    If IsArray(Dosyalar) Then  '<~~ Çoklu Seçim Yapıldıysa
        For Each Dosya In Dosyalar
            DosyaSecilenAktar Dosya
        Next Dosya
    Else '<~~ Tek Seçim Yapıldıysa
        If Dosyalar = True Then
            DosyaSecilenAktar Dosyalar
        Else
'            MsgBox "Dosya Seçilmedi.."
        End If
    End If
End Sub

Sub DosyaSecilenAktar(DosyaAdi As Variant)

    Dim Yol As String
    Dim i As Integer
    Dim cn As Object
    Dim Rs As Object
   
    Set cn = VBA.CreateObject("adodb.Connection")
    Set Rs = VBA.CreateObject("adodb.Recordset")
   
    Application.ScreenUpdating = False
   
    Yol = DosyaAdi
    i = Cells(Rows.Count, "B").End(3).Row + 1
    cn.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & Yol & _
        ";Extended Properties='Excel 12.0;HDR=YES';"

    cn.Open
   
    Rs.ActiveConnection = cn
   
    Rs.Source = "SELECT * FROM [Güncelleme Bilgileri$]"
   
    Rs.Open
    Sayfa1.Range("A" & i) = DosyaAdi
    Sayfa1.Range("B" & i).CopyFromRecordset Rs
   
    Rs.Close
    cn.Close

    Set Rs = Nothing
    Set cn = Nothing
   
    i = Cells(Rows.Count, "B").End(3).Row
    Range("A1:A" & i).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
 
    Application.ScreenUpdating = True
   
End Sub

Sub DosyaVeriSil()

    Dim EH As String
   
    EH = MsgBox("Verileri Silmek İstediğinizden Emin Misiniz?", vbYesNo, "Silme İşlemi")
    If EH = vbYes Then
        Range("A1").CurrentRegion.Offset(1).ClearContents
    Else
        MsgBox "SİLMEKTEN VAZ GEÇTİNİZ...."
    End If
       
End Sub

hocam çok teşekkürler mükemmel olmuş tam istediğim gibi excell dosyasında sadece tek satırda bilgi varsa hataya düşüyor. ekran resmini bakabilirseniz sevinirm
sadece a2 satırında bilgi var

 

[Necdet]

Merhaba.

Tek veri olacağını düşünemedim tabi o satırı şu şekilde kullanın :

If i > 2 Then Range("A1:A" & i).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"

 

[sevensuleyman]

Merhaba.

Tek veri olacağını düşünemedim tabi o satırı şu şekilde kullanın :

If i > 2 Then Range("A1:A" & i).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"

hocam senide uğraştırıyorum ama kusura bakma ; tek excell seçtiğimde sorun yok. çoklu excell seçtiğimde aynı satırda hataya düşüyor. teşekkürler

 

[Necdet]

hmmm o zaman o satıı silin, ben formül olmasın diye onu uygulamıştım.
Vakit bulduğumda çözüm öneririm

 

[Necdet]

Merhaba,

2. Mesajımda
DosyaSecilenAktar makrosunu ve dosyayı değiştirdim, tekrar bakar mısınız?

 

[sevensuleyman]

çok teşekkür ederim mükemmel çalışıyor.

 

[Necdet]

Güle güle kullanınız.