• DİKKAT

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

Kapalı Dosyaları Tek Bir Kitapta Birleştirme

B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
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.
 
Son düzenleme:
Asri Hocam,

Sürücü yolunu girdim, başlattım, herhangi bir hata vermiyor
ama üstte YANIT VERMİYOR yazıyor.
 
VBA alanına girmeye çalışınca "Error in Loading DLL" hatası verdi.
 
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
 
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
Genişletmek için tıkla ...

Ç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?
 
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?
Genişletmek için tıkla ...

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.
 
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
 
Son düzenleme:
İ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ç :)
 
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ç :)
Genişletmek için tıkla ...

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

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
 
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 içindeki veriler sürekli değişiyor, başka departmanlara gidiyor.
 
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.
Genişletmek için tıkla ...
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.
 
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?
Genişletmek için tıkla ...

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 :)
 
Dosya güncellendi.

Sıralama tamamlandı. Alfabetik sıralama yapacaktır.
 
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.
Genişletmek için tıkla ...

Daha önce yazdım ama dikkate almadınız.
Örnek dosyalarınızı gönderir misiniz?
 
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.
 

Ekli dosyalar

  • Deneme.rar
    Deneme.rar
    60.8 KB · Görüntüleme: 24
  • 2017-08-01_22-50-58.png
    2017-08-01_22-50-58.png
    4.1 KB · Görüntüleme: 15
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.
Genişletmek için tıkla ...

İş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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst