Çözüldü VBA İle Tablo Birleştirme

[ErdalÖzdemir]

Merhaba arkadaşlar.

Yapmak istediğim işlem;
Birden çok Excel dosyasından belirli başlıkları ANA TABLO da alt alta birleştirmek. Bu işlemi VBA ile yapıyorum, fakat boş olan hücreler İlgili isimin karşısına gelmesi gerekirken en sona, ilgisi olmayan ismin karşısına atıyor. Ben çok uğraştım ama çözemedim.

Örnek dosyaları ekledim.

Yardımlarınız için şimdiden teşekkür ederim.

 

[ErdalÖzdemir]

Merhaba arkadaşlar.

Bu konuyu iki defa üs tüste sorduğum halde 3-4 gündür bir cevap bile alamadım. Neden cevap alamadığımı da bilmiyorum. Acaba site kurallarına aykırı bir sor mu sordum, engellendim ise neden engellendim, yoksa gerçekten sorumun cevabı yok mu. Hiçbir şey anlamadım.

 

[Saban Sertkaya]

Bu konularda çok iyi değilim ama dosyanızı alternatif bir linke yükleyebilir misiniz acaba. Bakmak isterim doğrusu.

 

[Korhan Ayhan]

Merhaba,

Bu işlem için makro kullanmanıza gerek yok. Eğer Kullandığınız sürüm destekliyorsa aşağıdaki görselde tarif ettiğim menüyü kullanarak dinamik şekilde dosyaları birleştirebilirsiniz.



Kaynak olarak bu videoyu izleyerek kolaylıkla yapabilirsiniz.

 

[Korhan Ayhan]

Kod ile aşağıdaki gibi olabilir.

Dosya yolunu kendinize göre düzenlersiniz.

Option Explicit

Sub File_Concatenate()
    Dim My_Folder As String, My_File As String
    Dim My_Connection As Object, My_Recordset As Object
    Dim Process_Time As Double, Searched_File_Extension As String
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    My_Folder = ThisWorkbook.Path & "\RAPORLAR (DÜZENLENEN)\"
    
    Range("A2:G" & Rows.Count).Clear
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    
    Searched_File_Extension = "*.xls*"
    
    My_File = Dir(My_Folder & Searched_File_Extension)
    
    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            My_Folder & My_File & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
            
            Set My_Recordset = My_Connection.Execute("Select [No],[Ad Soyad],[Puanı],[Kod],[Sayısı],[Renk],'" & My_File & "' From [Sayfa1$]")
                   
            Cells(Rows.Count, 1).End(3)(2, 1).CopyFromRecordset My_Recordset
       
            If My_Recordset.State <> 0 Then My_Recordset.Close
            If My_Connection.State <> 0 Then My_Connection.Close
        End If
       
        My_File = Dir
    Wend
    
    Columns("A:G").AutoFit
    
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[ErdalÖzdemir]

Korhan Bey, teşekkür ederim. Kod işlem yapıyor fakat iki nokta var; birincisi, birleştirme yapılan dosyalardaki başlıklar ile vereleri birleştirdiğim dosyadaki başlıkları aynı ise ilgili başlığın altına verileri getirsin, başlık aynı değilse boş getirsin. Birde birleştirilen dosyaların sütun sayıları aynı olmaya biliyor ve bunlardan bir kısmını almam gerekebilir.

Ayrıca kullandığım kodda nasıl bir değişiklik yaparsam boşlukları sona değil de ilgili ismin karşısına getirebilirim. Yukarıda bahsettiğim sorunları kullandığım kodda yaşamıyorum.

Kullandığım kod:

Sub DOSYALARİ_BİRLESTİR()

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

Dim wb As Workbook
Dim wsa As Worksheet
Dim ws As Worksheet
Dim lr, lc, lra, lca, c, r As Long

Dim yol As String
Dim Folder As Folder
Dim File As File

Set ws = Sayfa1
ws.Range("A2:AZ" & Rows.Count).Clear

Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")

yol = "\RAPORLAR (DÜZENLENEN)"

On Error Resume Next

Set Folder = FileSystem.GetFolder(yol)
'Set Klasör = Rky.GetFolder(yol).Files

For Each File In Folder.Files
'If LCase(FileSystem.GetExtensionName(File)) Like "*xl*" Then

If FileSystem.GetFileName(File) Like "*DENEME1*" _
Or FileSystem.GetFileName(File) Like "*DENEME3*" _
Or FileSystem.GetFileName(File) Like "*DENEME2*" Then

Set wb = Workbooks.Open(File, False, True)
Set wsa = wb.Sheets(1)

On Error Resume Next

lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row: 'MsgBox lra
lca = wsa.Cells(1, Columns.Count).End(xlToLeft).Column: 'MsgBox lca

lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For c = 1 To lc
For ca = 1 To lca

If wsa.Cells(1, ca) = ws.Cells(1, c) Then
cn = ca
Exit For

Else
cn = ""

End If
Next ca

For r = 2 To lra
y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row

If c <> lc Then
ws.Cells(y, c) = wsa.Cells(r, cn)

Else
ws.Cells(y, c) = FileSystem.GetFileName(File.Name)
y = y

End If
Next r
Next c

ws.UsedRange.EntireColumn.AutoFit
ws.UsedRange.EntireRow.AutoFit

wb.Close savechanges:=False

End If
Next File

Set wsa = Nothing

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

MsgBox "BAŞLIKLARI GÖRE VERİLER ÇEKİLDİ"

End Sub

 

[veyselemre]

Sub sutunBasliklarinaGoreDosyalardanVeriAl_ADO()
   
    Range("2:" & Rows.Count).ClearContents
    Dim strCon$, strSql$, pth$, rs As Object, _
    sqlFields, fullName$, fName, f, i%
   
    pth = ThisWorkbook.Path & "\RAPORLAR (DÜZENLENEN)\"
   
    For Each fName In Array("deneme1.xlsx", "deneme2.xlsx", "deneme2.xlsx")
       
        fullName = pth & fName
       
        strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & fullName & _
                 "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"
               
        sqlFields = Array("[No]", "[Ad Soyad]", "Puanı", "Kod", "Sayısı", "Renk")
   
        Set rs = CreateObject("Adodb.RecordSet")

        strSql = " SELECT * FROM [Sayfa1$] "
   
        rs.Open strSql, strCon
   
        With CreateObject("Scripting.Dictionary")
            For Each f In rs.Fields
                .Item(f.Name) = Null
            Next f
            For i = 0 To UBound(sqlFields)
                If Not .Exists(Replace(Replace(sqlFields(i), "[", ""), "]", "")) Then
                    sqlFields(i) = "''"
                End If
            Next
       
        End With
   
        rs.Close
   
        strSql = " SELECT " & Join(sqlFields, ",") & ",'" & fName & "' FROM [Sayfa1$] WHERE [No] IS NOT NULL"
   
        rs.Open strSql, strCon
        Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
        rs.Close
    Next
    Set rs = Nothing

End Sub

Sub sutunBasliklarinaGoreDosyalardanVeriAl_ADO()
    
    Range("2:" & Rows.Count).ClearContents
    Dim strCon$, strSql$, pth$, rs As Object, _
    sqlFields, fullName$, fName, f, i%
    
    pth = ThisWorkbook.Path & "\RAPORLAR (DÜZENLENEN)"
    
    fName = Dir(pth & "\*.xls?")
  
    Do While fName <> ""
        
        If fName Like "*Resmi*" _
           Or fName Like "*Özel*" _
           Or fName Like "*MEB*" Then
        
            fullName = pth & "\" & fName
        
            strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & fullName & _
                     "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"
                 
            sqlFields = Array("[No]", "[Ad Soyad]", "Puanı", "Kod", "Sayısı", "Renk")
    
            Set rs = CreateObject("Adodb.RecordSet")

            strSql = " SELECT * FROM [Sayfa1$] "
    
            rs.Open strSql, strCon
    
            With CreateObject("Scripting.Dictionary")
                For Each f In rs.Fields
                    .Item(f.Name) = Null
                Next f
                For i = 0 To UBound(sqlFields)
                    If Not .Exists(Replace(Replace(sqlFields(i), "[", ""), "]", "")) Then
                        sqlFields(i) = "''"
                    End If
                Next
        
            End With
    
            rs.Close
    
            strSql = " SELECT " & Join(sqlFields, ",") & ",'" & fName & "' FROM [Sayfa1$] WHERE [No] IS NOT NULL"
    
            rs.Open strSql, strCon
            Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
            rs.Close
        
        End If
        fName = Dir()
    Loop
    
    Set rs = Nothing

End Sub

 

[ErdalÖzdemir]

Veysel Bey, teşekkür ederim elinize emeğinize sağlık.

Her hangi bir başlığı kaldırdığımda veya başka bir başlık eklediğimde , tüm bilgileri yine getiriyor.
Hatta tüm başlıkları kaldırdığımda veriler yine geliyor.

Yapmaya çalıştığım; Birleştirme yapılan dosyalardaki başlıklar ile vereleri birleştirdiğim dosyadaki başlıklar aynı ise ilgili başlığın altına verileri getirsin, başlık aynı değilse boş getirsin.

 

[veyselemre]

sqlFields = Array("[No]", "[Ad Soyad]", "Puanı", "Kod", "Sayısı", "Renk")

Gelecek başlıklar burada tanımlanıyor. Burayı düzenlediğinizde istediğiniz alanlar gelecektir.
Köşeli parantezler arada boşluk bulunan başlıklarda ve No da kullanılmıştır. No kelimesi SQL tarafında kullanılan bir ifade olduğundan parantez içine alınmıştır. Bütün başlıkları köşeli parantez içinde de yazabilirsiniz.

 

[ErdalÖzdemir]

Veysel Bey,
Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs 'burada birinci sütun boş, ikinci sütuna raporun "[No]", üçüncü sütun boş, dördüncü sütuna [Ad Soyad] şeklinde verileri getirebilir miyiz

Örnek:
Dosyaların birleştiği sayfadaki başlıklar; """", "No", "Ad Soyad", """","Puanı", "Kod", """", """", "Sayısı", """", "Renk", """" şeklinde raporun gelmesini sağlaya bilir miyiz

 

[Haluk]

Veysel Bey'in izniyle;

Aşağıdaki satırları kodda eskileriyle değiştirirseniz, olur....

        sqlFields = Array("", "[No]", "", "[Ad Soyad]", "", "Puanı", "", "Kod", "", "Sayısı", "", "Renk")

        strSql = " SELECT " & Join(sqlFields, ",") & ",'','" & fName & "' FROM [Sayfa1$] WHERE [No] IS NOT NULL"

.

 

[ErdalÖzdemir]

Şaban Hocam, Korhan Hocam, Veysel Hocam ve Haluk Hocam hepinize çok teşekkür ederim.
Elinize emeğinize sağlık.

 

[Korhan Ayhan]

Arkadaşlarım çözüm sunmuşlar. Bende önerdiğim kodu talebinize göre revize ettim. Umarım doğru anlamışımdır.

 

[ErdalÖzdemir]

Korhan Hocam;
Benim ilk etapta istediğim; Kullandığım dosya birleştirme kodunda nasıl bir değişiklik yaparsam boşlukları sona değil de ilgili ismin karşısına getirebilirim? sorusu idi.
Burada kullandığım kod ADO değil VBA idi. Bu şekilde ADO ile de dosya birleştirme kodunu görmüş oldum. Teşekkür ederim.

Hayırlı akşamlar.

 

[Korhan Ayhan]

Bir gün forum aşırı hızdan alev alacak..