Soru Kapalı Dosyaların Tümünü Seç ve Birleştir.

[ormann]

Ben hala anlamış değilim.Hiçbir şekilde görmüyor

 

[metin_0606]

Haluk hocam çalışmanızı silip tekrar indirdim 64 bitte çalıştı. Sayın ormanın istediği şekilde çalışmanız bende çalıştı. Herhangi bir sorun yok

A3 ten değilde A2 den itibaren itibaren kopyalamasına bende anlam veremedim. Çözüm bulmanız halinde paylaşırsanız seviniriz. Saygılar

 

[Merhum İdris SERDAR]

.

Sayın ormann,

Herne kadar verdiğim yanıtı görmezden geldiyseniz de, birleştirme isteğiniz bu şekilde ise, yukarıda verdiğim linkteki dosyayı kullanın.

İndir Dosya Birleştirme1

Dosyayı indir Dosya Birleştirme1

dosya.co

.

.

 

[metin_0606]

Ben hala anlamış değilim.Hiçbir şekilde görmüyor

Sayın Orman klasörün içimi boş görünüyor

 

[ormann]

Sayın Orman klasörün içimi boş görünüyor

Sayın Metin klasör aç dediğimde hiç bir Excel dosyasını görmüyor masaüstü dahil

 

[metin_0606]

Sayın Metin klasör aç dediğimde hiç bir Excel dosyasını görmüyor masaüstü dahil

Haluk beyin gönderdiği proğram bende sorunsuz çalıştı. Ancak sizde neden böyle yaptı açıkçası bilmiyorum . Haluk hocamın affına sığınarak masaüstü kopyalama kısmını her pc de olacak şekilde haluk hocamın makrosundan alarak revize ettim.
link:

İndir ASIL DOSYA

Dosyayı indir ASIL DOSYA

dosya.co

 

[ormann]

.

Sayın ormann,

Herne kadar verdiğim yanıtı görmezden geldiyseniz de, birleştirme isteğiniz bu şekilde ise, yukarıda verdiğim linkteki dosyayı kullanın.

İndir Dosya Birleştirme1

Dosyayı indir Dosya Birleştirme1

dosya.co

.

.

İdris bey kusura bakmayın. Görmemişim . Evet dosya tam istediğimi yapıyor. Fakat bazı yerleri şu şekilde olması gerekiyor.
* Ana dosyayı da birleştiriyor.
* Birleşen dosyalar masaüstünde yeni bir dosya olarak kayıt yapılacak Dosya Adı : BİRLEŞEN EBAT LİSTELERİ
* Sayfa adı istifEbatExcel olacak

 

[Korhan Ayhan]

Alternatif;

Option Explicit

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

    Zaman = Timer
   
    If IsArray(Dosya) Then
        Set Baglanti = CreateObject("AdoDb.Connection")
        Set S1 = Sheets("istifEbatExcel")
       
        S1.Range("A2:D" & S1.Rows.Count).ClearContents
   
        For X = LBound(Dosya) To UBound(Dosya)
            If Dosya(X) <> ThisWorkbook.FullName Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                Dosya(X) & ";Extended Properties=""Excel 12.0;Hdr=No"""
               
                Sorgu = "Select * From [istifEbatExcel$A2:D]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
               
                Kayit_Seti.Close
                Baglanti.Close
            End If
        Next
   
        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
       
        If Son = 1 Then
            MsgBox "Veri bulunamadı!", vbCritical
            GoTo 10
        ElseIf Son >= 2 Then
            If Son = 2 Then Son = 3
            Veri = S1.Range("A2:A" & Son).Value
           
            With CreateObject("Scripting.Dictionary")
                For X = LBound(Veri) To UBound(Veri)
                    If Veri(X, 1) <> "" Then .Item(Veri(X, 1)) = 1
                Next
               
                Ebat = Join(.Keys, "-")
            End With
       
            S1.Copy
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs CreateObject("WScript.Shell").Specialfolders("Desktop") & _
            Application.PathSeparator & "BİRLEŞTİRİLEN EBAT LİSTELERİ-(" & Ebat & ").xlsx", 51
            ActiveWorkbook.Close
            Application.DisplayAlerts = True
           
            MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        End If
   
10
        Set S1 = Nothing
        Set Kayit_Seti = Nothing
        Set Baglanti = Nothing
    Else
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
    End If
End Sub

 

[Merhum İdris SERDAR]

.

1. Ana dosyada ne var? Ana dosyanızı açmayın. Sadece benim dosyayı açın. Ve dosyaları seçerken ana dosyanızı seçmeyin.

2. Sayfa adını istediğiniz şekilde elle yapın.

3. Dosya adını istediğiniz şekilde ve istediğiniz yere kaydedin.

Gerçi 2 ve 3 makroyla da yapılabilir. Ama benim şablon dosya genel.

.

 

[ormann]

Alternatif;

Option Explicit

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

    Zaman = Timer
   
    If IsArray(Dosya) Then
        Set Baglanti = CreateObject("AdoDb.Connection")
        Set S1 = Sheets("istifEbatExcel")
       
        S1.Range("A2:D" & S1.Rows.Count).ClearContents
   
        For X = LBound(Dosya) To UBound(Dosya)
            If Dosya(X) <> ThisWorkbook.FullName Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                Dosya(X) & ";Extended Properties=""Excel 12.0;Hdr=No"""
               
                Sorgu = "Select * From [istifEbatExcel$A2:D]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
               
                Kayit_Seti.Close
                Baglanti.Close
            End If
        Next
   
        S1.Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs CreateObject("WScript.Shell").Specialfolders("Desktop") & _
        Application.PathSeparator & "BİRLEŞTİRİLEN EBAT LİSTELERİ.xlsx", 51
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
   
        Set S1 = Nothing
        Set Kayit_Seti = Nothing
        Set Baglanti = Nothing
   
        MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
    End If
End Sub

Korhan bey çok teşekkür ederim. Kod tam istediğim şekilde çalışıyor. Hızlı ve kullanışlı olabilirse son bir ekleme yapabilir misiniz ?
Birleştirilen dosya adı her dosyadan alınan "A" sutununda ki istif numarası ile şu şekilde yeni dosya adı verebilir mi?
BİRLEŞTİRİLEN EBAT LİSTELERİ-(12-13-14)
Not: Parentez içindeki numaralar alınan dosyadaki "A" sutunundaki isitf nuamraları

 

[Haluk]

A3 ten değilde A2 den itibaren itibaren kopyalamasına bende anlam veremedim. Çözüm bulmanız halinde paylaşırsanız seviniriz. Saygılar

Sanırım sıkıntıyı anladım .......

SQL komutu "Insert Into"; dosyadaki "istifEbatExcel" tablosunda ilgili alanların en sonundan başlayarak satır ilave etmek suretiyle yeni kayıtları ekler.

Ama, bizim tabloda sadece başlıklar var, tablonun içeriği boş. O zaman bu komut; tablonun en sonu olan 2nci satırı buluyor ve bir sonraki satırdan yani 3ncü satırdan başlayarak yeni kayıtları ilave ediyor.

Bu dediklerimi test etmek için, dosyadaki tabloda 2nci satırda A2, B2, C2, D2 hücrelerine gelişigüzel değerler girelim ...... örneğin hepsine "2" değerini girelim. Daha sonra kodu çalıştırdığımızda, bir problem olmayacaktır.

Yani işin esprisi; "Insert Into" komutu ile içine veri dolduracağımız tabloda en az 1 satır kayıt olması gerekiyor. Eğer bu şart sağlanmıyorsa, o zaman kod çalıştıktan sonra, tablonun 2. satırı yine VBA kodlarıyla silinir ve sorun biter.

.

 

[Korhan Ayhan]

#28 nolu mesajımı revize ettim. Tekrar deneyiniz.

 

[ormann]

Günaydınlar;
Sayın Korhan beye, Sayın İdris beye, Sayın Haluk beye ve Sayın Mete beye konu ile ilgili katkı ve desteklerinden ötürü çok teşekkür ederim.Saygılar sunuyorum