Çalışma kitaplarındaki sayfaları tek bir kitapta toplamak

megadeth61 · 26 Nisan 2011

Merhabalar,

Yaklaşık 200 tane farklı çalışma kitabındaki sayfaları tek bir çalışma kitabına toplamanın kolay bir yolu var mı acaba. Taşı kopyala seçeneğiyle saatlerce uğraşmadan önce sizlere danışmak istedim.

Saygılarımla,

Korhan Ayhan · 26 Nisan 2011

Selamlar,

Elbette var. Konuyla ilgili veri alınacak dosyalardan örnek eklerseniz yardımcı olabiliriz.

halit3 · 26 Nisan 2011

Kodu bir modülün içine ekleyiniz.

Kod:

Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Sub Start()
Sayfa_Adı = ActiveSheet.Name
dosya_adı = ActiveWorkbook.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Call AltListe(Kaynak, "")
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 Klasor = Nothing
End Sub
Private Sub AltListe(Klasor As String, uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String
Set Hedef = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*.**") ' & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = ThisWorkbook.Sheets.Count
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Klasor & "\" & Dosya)
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
End If
Dosya = Dir
wb.Close False
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call AltListe(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub

megadeth61 · 27 Nisan 2011

Merhabalar,

Korhan Bey,

Örnek dosyalar ektedir. Bu dosyalar içerisindeki sayfaları yeni bir çalışma kitabının altında toplamak istiyorum.

Halit Bey,

Modül oluşturdum ve kodu ekledim ama hiçbir şey olmadı. Sanırım beceremedim.

Bu iş kod kullanmadan yapabilme imkanımız varsa çok iyi olur. Şayet yok ise izlenecek adımları açık bir şekilde yazabilirseniz çok memnun olurum.

İlginiz çin şimdiden teşekkür ederim

Saygılarımla,

megadeth61 · 27 Nisan 2011

Yardımcı olabilir misiniz ?

halit3 · 28 Nisan 2011

örnek dosyanızı çalıştırmak için makro güvenlik düzeyi orta veya düşük olmalı yani makrolar etkin olmalı

numan şamil · 28 Nisan 2011

Halit hocam merhaba
müsade varsa tam burda bir şey sormak istiyorum mesaj 6 örnek dosyanızda sayfalardaki tüm verileri değilde her sayfanın örn:A3-C8-H4- D6 hücre değerlerini alamak istersek kodları nasıl revize etmemiz gerekiyor?

halit3 · 28 Nisan 2011

numan şamil' Alıntı:
Halit hocam merhaba
müsade varsa tam burda bir şey sormak istiyorum mesaj 6 örnek dosyanızda sayfalardaki tüm verileri değilde her sayfanın örn:A3-C8-H4- D6 hücre değerlerini alamak istersek kodları nasıl revize etmemiz gerekiyor?

Bu kod o işi yapmaz bu sadece sayfaları birleştiriyor

aradığınız şeyi sizede daha önceden yaptığımı hatırlıyorum.

numan şamil · 28 Nisan 2011

Halit hocam sizden çok yardım aldım hakkını helal et daha önce dosyaların ilk sayfalarından veri almak hususunda yardımcı oldunuz şimdi 3 adet dosyam var bu dosyalarda yaklaşık sürekli artan 70 ' e yakın sayfa var bu sayfalardaki belirli hücrelerdeki verileri tek kitapta ayrı ayrı sayfalarda toplamak istiyorum ( başka klosörde bulunan dosyaların sayfalarından veri almak başlığı altında buna benzer yeni konu açmıştım henüz daha bir cevap alamadım)

kemal turan · 10 Eylül 2011

Halit hocam
Ellerinize sağlık bir hayal kodu yazmışsınız.
Selametle..

cemocan11 · 6 Ekim 2011

halit3' Alıntı:
Bu kod o işi yapmaz bu sadece sayfaları birleştiriyor

aradığınız şeyi sizede daha önceden yaptığımı hatırlıyorum.

hocam size bir soru sormak istiyorum ama umarım cevaplarsınız

excelde hangi personelimin hangi projeye kaç saat çalıştığını ayrıca gün içerisindeki mola saatlerini düşerek ve mesai saatinden sonraki saatleri de mesai saati olarak hesaplayacak ayrıca , cuma günleri farklı mesai uygulamasını da dikkate alarak hesaplatmak istiyorum bu konu ile ilgili yardımcı olabilirseniz sevinirim

juninho10 · 22 Kasım 2011

selam hocam aynı şey benimde aklıma geldi.tek bir excell sayfasında iç içe kitaplar oluşturamazmıyız ?böyle birşey olsa gereksiz dosya çöplüğünden kurtulmuş olurduk.hani yeni bir çalışma kitabı açınca altında sayfa1,sayfa2 diye devam ediyor ya,o sayfalarında hemen altında kitaplar için ayrı bir yer olsa onlar da kitap1 kitap 2 diye devam etse ve bunların hepsini içine alsa süper olurdu.umarım derdimi anlatabilmişimdir.şimdiden teşekkürler.

ugurcadir · 30 Kasım 2011

juninho10' Alıntı:
selam hocam aynı şey benimde aklıma geldi.tek bir excell sayfasında iç içe kitaplar oluşturamazmıyız ?böyle birşey olsa gereksiz dosya çöplüğünden kurtulmuş olurduk.hani yeni bir çalışma kitabı açınca altında sayfa1,sayfa2 diye devam ediyor ya,o sayfalarında hemen altında kitaplar için ayrı bir yer olsa onlar da kitap1 kitap 2 diye devam etse ve bunların hepsini içine alsa süper olurdu.umarım derdimi anlatabilmişimdir.şimdiden teşekkürler.

bence bir sayfayı çalışma kitaplar olarak kullansan kitaba bağlantı atsan daha mantıklı. ve ctrl+f komutu ile istedğin kitabı kolayca bulabilirsin bunu dene bence

muratyurdakul · 30 Ocak 2012

Allah Razı olsun ya saatlerce yapacağım işi anında çözdü..sonsuz teşekkürler..

kucukdunyam · 12 Nisan 2013

kodu kullandım çok güzel olmuş, ancak bir ilave özellik soracaktım.
birleştirilen excel dosyasının içerisindeki sayfaların adını kaynak dosyaların ismini ni de ilaveten yazdırabilirmiyiz. örneğin DR2-MR0030(sayfa1), DR2-MR0031(sayfa1), DR2-MR0032(sayfa1), gibi.

halit3 · 12 Nisan 2013

kucukdunyam' Alıntı:
kodu kullandım çok güzel olmuş, ancak bir ilave özellik soracaktım.
birleştirilen excel dosyasının içerisindeki sayfaların adını kaynak dosyaların ismini ni de ilaveten yazdırabilirmiyiz. örneğin DR2-MR0030(sayfa1), DR2-MR0031(sayfa1), DR2-MR0032(sayfa1), gibi.

Konu baya eskimiş ne yaptığımızıda unutuyoruz bu aralar aşağıdaki kodu bir deneyin sonucundan bilgi verin.

Kod:

Kod:

Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Sub Start()
Sayfa_Adı = ActiveSheet.Name
dosya_adı = ActiveWorkbook.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Call AltListe(Kaynak, "")
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 Klasor = Nothing
End Sub
Private Sub AltListe(Klasor As String, uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String
Set Hedef = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*.**") ' & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = ThisWorkbook.Sheets.Count
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Klasor & "\" & Dosya)
[COLOR=red]dosyaadi = CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya)[/COLOR]
[COLOR=red]For i = 1 To ActiveWorkbook.Sheets.Count[/COLOR]
[COLOR=red]Sheets(i).Name = dosyaadi & "(" & Sheets(i).Name & ")"[/COLOR]
[COLOR=red]Next[/COLOR]
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
End If
Dosya = Dir
wb.Close False
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call AltListe(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub

halit3 · 12 Nisan 2013

Buda farklı bir kod:

Kod:

Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Sub Start()
Sayfa_Adı = ActiveSheet.Name
dosya_adı = ActiveWorkbook.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
sat1 = ThisWorkbook.Sheets.Count
sayfaadi2 = Sheets(sat1).Name
uzanti2 = CreateObject("Scripting.FileSystemObject").GetExtensionName(ThisWorkbook.Name)
If Len(uzanti2) = 3 Then
Liste1 (Kaynak)
Else
Liste2 (Kaynak)
End If
Sheets(sayfaadi2).Move Before:=Sheets(sat1)
Application.DisplayAlerts = False
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 Klasor = Nothing
End Sub
 
Private Sub Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
For Each Dosya In fs
uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)
If uzanti = "xls" Then
If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
dosyaadi = CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Name = dosyaadi & "(" & Sheets(i).Name & ")"
Next
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
sat = ThisWorkbook.Sheets.Count
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
wb.Close False
End If
End If
Next

On Error GoTo sonraki
For Each f In fL
Liste1 (f.Path)
sonraki:
Next
Set Hedef = Nothing
End Sub
 
Private Sub Liste2(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
For Each Dosya In fs
uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)
If uzanti = "xls" Or uzanti = "xlsx" Or uzanti = "xlsm" Then
If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
dosyaadi = CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Name = dosyaadi & "(" & Sheets(i).Name & ")"
Next
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
sat = ThisWorkbook.Sheets.Count
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
wb.Close False
End If
End If
Next
On Error GoTo sonraki
For Each f In fL
Liste2 (f.Path)
sonraki:
Next
Set Hedef = Nothing
End Sub

haşimzade · 24 Temmuz 2014

halit3' Alıntı:

Buda farklı bir kod:

Kod:

Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Sub Start()
Sayfa_Adı = ActiveSheet.Name
dosya_adı = ActiveWorkbook.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
sat1 = ThisWorkbook.Sheets.Count
sayfaadi2 = Sheets(sat1).Name
uzanti2 = CreateObject("Scripting.FileSystemObject").GetExtensionName(ThisWorkbook.Name)
If Len(uzanti2) = 3 Then
Liste1 (Kaynak)
Else
Liste2 (Kaynak)
End If
Sheets(sayfaadi2).Move Before:=Sheets(sat1)
Application.DisplayAlerts = False
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 Klasor = Nothing
End Sub
 
Private Sub Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
For Each Dosya In fs
uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)
If uzanti = "xls" Then
If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
dosyaadi = CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Name = dosyaadi & "(" & Sheets(i).Name & ")"
Next
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
sat = ThisWorkbook.Sheets.Count
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
wb.Close False
End If
End If
Next

On Error GoTo sonraki
For Each f In fL
Liste1 (f.Path)
sonraki:
Next
Set Hedef = Nothing
End Sub
 
Private Sub Liste2(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
For Each Dosya In fs
uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)
If uzanti = "xls" Or uzanti = "xlsx" Or uzanti = "xlsm" Then
If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
dosyaadi = CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Name = dosyaadi & "(" & Sheets(i).Name & ")"
Next
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate
sat = ThisWorkbook.Sheets.Count
ActiveWorkbook.Worksheets.Copy Before:=Workbooks(dosya_adı).Sheets(sat)
wb.Close False
End If
End If
Next
On Error GoTo sonraki
For Each f In fL
Liste2 (f.Path)
sonraki:
Next
Set Hedef = Nothing
End Sub

bu kod tüm sorunları çözmüş. sırf size teşekkür etmek için üye oldum, beni çok büyük dertten kurtardınız

teşekkürler.

Çalışma kitaplarındaki sayfaları tek bir kitapta toplamak

megadeth61

Korhan Ayhan

Administrator

halit3

Uzman

megadeth61

Ekli dosyalar

megadeth61

halit3

Uzman

Ekli dosyalar

numan şamil

Destek Ekibi

halit3

Uzman

numan şamil

Destek Ekibi

kemal turan

cemocan11

Ekli dosyalar

juninho10

ugurcadir

muratyurdakul

kucukdunyam

halit3

Uzman

halit3

Uzman

Ekli dosyalar

haşimzade