Kapalı Dosyaları Tek Bir Kitapta Birleştirme

BedriA · 1 Ağustos 2017

Arkadaşlar,

Aynı klasör içindeki excel dosyalarını tek bir kitapta toplamak istiyorum.
Diyelim ki 7 tane dosyam var. Her dosyada bir sayfa ve her bir sayfanın farklı bir adı var. Sayfa adları değişmeyecek şekilde, bu 7 dosyayı tek bir dosyada birleştirmek istiyorum.

7 dosya içindeki sayfa adları diyelim sırayla A, B, C, D, E, F, G olsun. Birleştirilmiş çalışma dosyasında bu sayfalar, A, B, ...., G şeklinde yan yana sıralansın.

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

Asri · 1 Ağustos 2017

Yani şimdi hazırı var desem de hayal ettiğiniz gibi olmayacaktır

http://asriakdeniz.com/tum-excel-dosyalari-tek-dosyada

BedriA · 1 Ağustos 2017

Asri Hocam,

Sürücü yolunu girdim, başlattım, herhangi bir hata vermiyor
ama üstte YANIT VERMİYOR yazıyor.

BedriA · 1 Ağustos 2017

VBA alanına girmeye çalışınca "Error in Loading DLL" hatası verdi.

halit3 · 1 Ağustos 2017

Aşağıdaki linki irdele benzer kodlar mevcut.

http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html

kod:

Kod:

Sub Klasördeki_Dosyaların_Bütün_Sayfalarını_Taşıyarak_Bu_Dosyaya_Kopyala()

Sayfa_Adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Application.ScreenUpdating = False
Liste4 (Klasor.Items.Item.Path)
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste4(yol As String)
Dim fL As Object, fs As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

dosya_adı = ThisWorkbook.Name
Dim wb As Workbook



aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fL.GetFolder(yol).Files

If ThisWorkbook.Name = dosya Then GoSub atla1
If Mid(fL.GetExtensionName(dosya), 1, 2) = "~$" Then GoSub atla1

deg = 0
uzanti = LCase(fL.GetExtensionName(dosya.Name))

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
deg = 1
Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then
deg = 1
Else
GoSub atla1
End If
End If

If deg = 1 Then
Set wb = Workbooks.Open(dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
Application.DisplayAlerts = False
say = ThisWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Copy After:=Workbooks(ThisWorkbook.Name).Sheets(say)
ThisWorkbook.Sheets(ActiveSheet.Name).Name = "Sayfa" & say + 1
Next i

wb.Close False
End If


atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub

BedriA · 1 Ağustos 2017

halit3' Alıntı:

Aşağıdaki linki irdele benzer kodlar mevcut.

http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html

kod:

Kod:

Sub Klasördeki_Dosyaların_Bütün_Sayfalarını_Taşıyarak_Bu_Dosyaya_Kopyala()

Sayfa_Adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Liste4 (Klasor.Items.Item.Path)
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste4(yol As String)
Dim fL As Object, fs As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

dosya_adı = ThisWorkbook.Name
Dim wb As Workbook

For Each dosya In fL.GetFolder(yol).Files

If fL.GetExtensionName(dosya) = "xls" Then
If ThisWorkbook.Name <> dosya Then
Set wb = Workbooks.Open(dosya)

For i = 1 To ActiveWorkbook.Sheets.Count
Application.DisplayAlerts = False
say = ThisWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Copy After:=Workbooks(ThisWorkbook.Name).Sheets(say)
ThisWorkbook.Sheets(ActiveSheet.Name).Name = "Sayfa" & say + 1
Next i

wb.Close False
End If

End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub

Çok teşekkür ederim Halit Hocam.
Linkteki dosya neredeyse bir külliyat, arşivimde varmış zaten.
Ama hiç biriyle istediğimi tam yapamadım, belki de ben beceremedim.

Şöyle anlatayım: Benim bir çalışma dosyam var. O dosyadan 7 ayrı dosya ihraç ediyorum. Bu dosyalar bir klasöre kaydoluyor. Ama bana bu 7 klasörün birleşik hali, (her dosyada bir sayfa var) yani bana 7 sayfalık bir dosya lazım.

Bu sayfa yerine (ActiveSheet.Name) açılacak yeni bir sayfaya kaydettirmek mümkün mü? Bu kadarı sorunumu çözecek.
Hocam bir de iki kod var burda, hangisi nereye tarif edebilir misiniz?

Asri · 1 Ağustos 2017

BedriA' Alıntı:
Çok teşekkür ederim Halit Hocam.
Linkteki dosya neredeyse bir külliyat, arşivimde varmış zaten.
Ama hiç biriyle istediğimi tam yapamadım, belki de ben beceremedim.

Şöyle anlatayım: Benim bir çalışma dosyam var. O dosyadan 7 ayrı dosya ihraç ediyorum. Bu dosyalar bir klasöre kaydoluyor. Ama bana bu 7 klasörün birleşik hali, (her dosyada bir sayfa var) yani bana 7 sayfalık bir dosya lazım.

Bu sayfa yerine (ActiveSheet.Name) açılacak yeni bir sayfaya kaydettirmek mümkün mü? Bu kadarı sorunumu çözecek.
Hocam bir de iki kod var burda, hangisi nereye tarif edebilir misiniz?

Bence siz örnek dosyalarınızı ve sonuç dosyasını klasörleri ile beraber zip layiıp dosya.tc yada co ya yükleyin.
Bu şekilde net cevap alırsınız.

BedriA · 1 Ağustos 2017

Halit Hoca'nın aşağıdaki kodu istediğime en yakın kod.
Ancak bu kod ile çalışma sayfasını ihraç ettiğimde, makroları siliyor formülleri silmiyor;
dolayısıyla sayfalarda bundan kaynaklı bozulma oluyor. Bu kod kopya nüshaya sadece sayfadaki verileri (değerleri)
gönderse harika olacak.

Kod:

Sub Birles()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
, 
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
'dosya_adi = fL.GetBaseName(Dosya) ' dosyanın kendisi
uzanti = fL.GetExtensionName(dosya) ' uzantı buluyor

dosya_adi = InputBox("       Uyarı" & Chr(10) & _
Chr(10) & "  Yeni Dosya adını yazınız " & Chr(10) & Chr(10) & _
"", "     Dikkat", "", , , "DEMO.HLP", 10)

If dosya_adi = "" Then
MsgBox "dosya adını yazmadınız.", vbInformation, "        Uyarı"
Exit Sub
End If

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz?", vbYesNo + vbInformation, "         Makro")

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

git = ActiveSheet.Name

Dim sayfa As Worksheet

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 0

If Sheets(i).Name <> "islem" And Sheets(i).Name <> "test" And Sheets(i).Name <> "testt" Then r = 1

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy


For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If Mid(dosya.Name, 1, Len(dosya_adi)) = dosya_adi Then
sat = sat + 1

If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & dosya_adi & sat & "." & uzanti) = True Then
Else
son = 1
Exit For
End If
End If
Next


If son = 0 Then
sat = ""
End If

deger = dosya_adi & sat & "." & uzanti

If yer = vbYes Then

For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(Sheets(i).Name).Select
Worksheets(Sheets(i).Name).Protect Password:="123", Contents:=False, Scenarios:=False
ActiveSheet.DrawingObjects.Delete
Next



For Each Component In ActiveWorkbook.VBProject.VBComponents
If Component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove Component
Else
Set modul = Component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If


ActiveWorkbook.Sheets(Sheets(1).Name).Select

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If


ActiveWorkbook.SaveAs Kaynak & deger, FileFormat:=FileFormatNum

'ActiveWorkbook.SaveAs Kaynak & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Kaynak & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, "       " & deger
Else
Atla:
MsgBox "Klasör seçimi yapınız.", vbInformation, "       DİKKAT"
End If
End Sub

Asri · 1 Ağustos 2017

İlk mesajımdaki dosya güncellendi.
Ana klasör ve alt klasörlerdeki .xls* dosyalarını bulur içindeki tüm sayfaları yeni bir tek dosyaya ekler.
Bu program yazılan ana klasör ve altındaki herhangi bir yerde bulunmamalıdır.

Sıralama önemli mi bilmiyorum o hariç

BedriA · 1 Ağustos 2017

asri' Alıntı:
İlk mesajımdaki dosya güncellendi.
Ana klasör ve alt klasörlerdeki .xls* dosyalarını bulur içindeki tüm sayfaları yeni bir tek dosyaya ekler.
Bu program yazılan ana klasör ve altındaki herhangi bir yerde bulunmamalıdır.

Sıralama önemli mi bilmiyorum o hariç

Maalesef önemli...
Bu defa çalışıyor ancak birleştirilmiş dosyayı silip yenisini oluşturunca, diğeri hiç silinmemiş gibi, sayfa isimleri tekrar ediyormuş gibi sayfa isimlerine rakam veriyor.

Asri · 1 Ağustos 2017

BedriA' Alıntı:
Maalesef önemli...
Bu defa çalışıyor ancak birleştirilmiş dosyayı silip yenisini oluşturunca, diğeri hiç silinmemiş gibi, sayfa isimleri tekrar ediyormuş gibi sayfa isimlerine rakam veriyor.

Mümkün değil, sonuç dosyası her defasında yeniden oluşturulup boş olarak kaydedildikten sonra yeni sayfalar içine ekleniyor.

Aynı sayfa isimlerinden çıkıyor ise sizin klasörlerinizdeki dosyaların içinde aynı sayfa isimlerinden vardır

Kod:

  On Error Resume Next
    Workbooks("Sonuc_Dosya.xlsx").Close SaveChanges:=False
    On Error GoTo 0
    
    Set aktifdosya = ActiveWorkbook
    Workbooks.Add
    kaydetyol = aktifdosya.Path & "\" & "Sonuc_Dosya" & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=kaydetyol

BedriA · 1 Ağustos 2017

Evet.
Ben zaten sürekli aynı klasörün içindeki aynı isimli dosyaları birleştireceğim.
Ama buna rağmen yeni dosya açtığı için böyle yapmaması gerekmez miydi?

BedriA · 1 Ağustos 2017

Dosyaların içindeki veriler sürekli değişiyor, başka departmanlara gidiyor.

Asri · 1 Ağustos 2017

7 dosya içindeki sayfa adları diyelim sırayla A, B, C, D, E, F, G olsun. Birleştirilmiş çalışma dosyasında bu sayfalar, A, B, ...., G şeklinde yan yana sıralansın.

Ben bu cümleden şunu anladım.
7 dosya var her birinde bir sayfa var bu
1. dosyadaki sayfa adı A
2. dosyadaki sayfa adı B
..
7. dosyadaki sayfa adı G

Bu durumda program sonuc dosyasında G,A,B,C,D,E,F gibi sonuç üretecektir. (şu an için dizmediğinden)

ancak 8. bir dosya daha her hangi bir klasörün altında var ise ve onun sayfa adı A ise
G,A,A(1),B,C,D,E,F gibi sonuç çıkar.

Program dosya adlarına değil, dosyaların içindeki sayfa adlarını dikkate alır.

Asri · 1 Ağustos 2017

BedriA' Alıntı:
Evet.
Ben zaten sürekli aynı klasörün içindeki aynı isimli dosyaları birleştireceğim.
Ama buna rağmen yeni dosya açtığı için böyle yapmaması gerekmez miydi?

Dosyaların isimlerinin bir önemi yokki, yada ben öyle anlamıştım.

Sonuç dosyası her defasında yeniden oluştuğu için, kaynak dosyalara sayfa adı olarak değişmediği sürece her çalışmada aynı sonucu verecektir.

En azından bende öyle çalışıyor

Asri · 1 Ağustos 2017

Dosya güncellendi.

Sıralama tamamlandı. Alfabetik sıralama yapacaktır.

BedriA · 1 Ağustos 2017

asri' Alıntı:
Dosya güncellendi.

Sıralama tamamlandı. Alfabetik sıralama yapacaktır.

Ben de her dosyayı 5-6 kez üst üste kaydetmiş gibi sonuç çıkıyor.
Oluşan yeni sonuç belgesinin için ana-baba günü oluyor.

Asri · 1 Ağustos 2017

BedriA' Alıntı:
Ben de her dosyayı 5-6 kez üst üste kaydetmiş gibi sonuç çıkıyor.
Oluşan yeni sonuç belgesinin için ana-baba günü oluyor.

Daha önce yazdım ama dikkate almadınız.
Örnek dosyalarınızı gönderir misiniz?

BedriA · 1 Ağustos 2017

Asri Hocam,

Çok özür dilerim, benden kaynaklı bir hata vardı.
Şu an düzgün çalışıyor. Ancak ufak bir nokta kaldı.

Ekte klasör var.
Dosyaların sıralanışı fotoğraftaki gibi olacak.
Ayrıca açılan yeni sayfaya sabit gelen üç sayfa silinecek.

Bunu da halledersek harika olacak.

Asri · 1 Ağustos 2017

BedriA' Alıntı:
Asri Hocam,
Ekte klasör var.
Dosyaların sıralanışı fotoğraftaki gibi olacak.
Ayrıca açılan yeni sayfaya sabit gelen üç sayfa silinecek.

Bunu da halledersek harika olacak.

İşte burada örnek dosyanın ne kadar doğru bir yöntem olduğu ortaya çıkıyor.

A,B,C,D diye konuyu giriyorsunuz , S,M,B,B,M,H,T diye sonuç oluşuyor

Kod özel çalışmaya dönüştüğü için aşağıdaki şekilde kullanın

Kod:

Dim aradizin, dosya, yenidosya As String

Sub menu()
    Application.DisplayAlerts = False
    aradizin = "C:\Deneme"
    On Error Resume Next
    Workbooks("Sonuc_Dosya.xlsx").Close SaveChanges:=False
    On Error GoTo 0
    
    Set aktifdosya = ActiveWorkbook
    Workbooks.Add
    kaydetyol = aktifdosya.Path & "\" & "Sonuc_Dosya" & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=kaydetyol
    yenidosya = ActiveWorkbook.Name
    
    dosya = aradizin & "\Sheet1.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("Sheet1").Copy Before:=Workbooks(yenidosya).Sheets(1)
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\MAL.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("MAL").Copy After:=Workbooks(yenidosya).Sheets("Sheet1")
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\BCF.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("BCF").Copy After:=Workbooks(yenidosya).Sheets("MAL")
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\BTS.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("BTS").Copy After:=Workbooks(yenidosya).Sheets("BCF")
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\HOC.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("HOC").Copy After:=Workbooks(yenidosya).Sheets("BTS")
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\POC.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("POC").Copy After:=Workbooks(yenidosya).Sheets("HOC")
    Workbooks(eskidosya).Close
    
    dosya = aradizin & "\TRX.xlsx"
    Workbooks.Open Filename:=dosya, UpdateLinks:=0
    eskidosya = ActiveWorkbook.Name
    Workbooks(eskidosya).Sheets("TRX").Copy After:=Workbooks(yenidosya).Sheets("POC")
    Workbooks(eskidosya).Close
   
    liste = "/TRX/POC/HOC/BTS/BCF/MAL/Sheet1/"
    For i = Sheets.Count To 1 Step -1
       isim = "/" & Sheets(i).Name & "/"
       If InStr(liste, isim) = 0 Then
          Sheets(i).Delete
       End If
    Next i
    
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
End Sub

Kapalı Dosyaları Tek Bir Kitapta Birleştirme

BedriA

Asri

BedriA

BedriA

halit3

Uzman

BedriA

Asri

BedriA

Asri

BedriA

Asri

BedriA

BedriA

Asri

Asri

Asri

BedriA

Asri

BedriA

Ekli dosyalar

Asri