• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

metin_0606' Alıntı:
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
Genişletmek için tıkla ...
A3 ten değilde A2 den itibaren itibaren kopyalamasına bende anlam veremedim. Çözüm bulmanız halinde paylaşırsanız seviniriz. Saygılar
 
.

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

.

.
 
ormann' Alıntı:
Sayın Metin klasör aç dediğimde hiç bir Excel dosyasını görmüyor masaüstü dahil
Genişletmek için tıkla ...
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
 
İdris SERDAR' Alıntı:
.

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

.

.
Genişletmek için tıkla ...
İ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
 
Alternatif;

C++: 
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
 
.

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.

.
 
Son düzenleme:
Korhan Ayhan' Alıntı:
Alternatif;

C++: 
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
Genişletmek için tıkla ...
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ı
 
metin_0606' Alıntı:
A3 ten değilde A2 den itibaren itibaren kopyalamasına bende anlam veremedim. Çözüm bulmanız halinde paylaşırsanız seviniriz. Saygılar
Genişletmek için tıkla ...


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.

.
 
#28 nolu mesajımı revize ettim. Tekrar deneyiniz.
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst