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

[metin_0606]

Arkadaşlar,
Aynı klasör içindeki excel dosyalarını tek bir kitapta toplamak istiyorum. Buna uygun çalışan bir makro varmı acaba

 

[metin_0606]

Güncel

 

[halit3]

Bu dosyayı nerede kullanacaksınz
diyelim klasörde 300 dosya ver her bir dosyada 3 sayfa varsa bunların hepsini dosya kaldırmaz
bir dosyanın alacağı sayfa sayısı aşağıdaki linkde verilmiş

https://www.excel.web.tr/threads/bir-dosyada-en-fazla-kac-sayfa-acilir.28185/

 

[metin_0606]

Bu dosyayı nerede kullanacaksınz
diyelim klasörde 300 dosya ver her bir dosyada 3 sayfa varsa bunların hepsini dosya kaldırmaz
bir dosyanın alacağı sayfa sayısı aşağıdaki linkde verilmiş

https://www.excel.web.tr/threads/bir-dosyada-en-fazla-kac-sayfa-acilir.28185/

Halit hocam klasörde 5 dosya ver her birinde birer sayfa var bu sayfalarda bana. Lazım olan veriler var ihtiyaç duyduğumda bunlari kendi calistigim çalışma kitabına sayfalar halinde getirtmek istiyorum

 

[halit3]

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
Application.DisplayAlerts = False
Liste1 (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 Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object
Dim sat As Long
Set fL = CreateObject("Scripting.FileSystemObject")

uzanti2 = fL.GetExtensionName(ThisWorkbook.Name)

Dim wb As Workbook
For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya.Name)

If Len(uzanti) > Len(uzanti2) Then GoTo Atla2
If ThisWorkbook.Name <> Dosya.Name Then
dosyaadi = fL.GetBaseName(Dosya)

If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoTo Atla2
End If


Set wb = Workbooks.Open(Dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
k = k + 1
Sheets(i).Name = Sheets(i).Name & "(" & k & ")"
Next
ActiveWorkbook.Worksheets.Select
Sheets(1).Activate

sat = ThisWorkbook.Sheets.Count
ActiveWorkbook.Worksheets.Copy After:=Workbooks(dosya_adı).Sheets(sat)
wb.Close False
End If
Atla2:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next
Set Hedef = Nothing
End Sub

 

[metin_0606]

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

Halit hocam yardımcınız için teşekkürler eve gidince PC de deniyecegim bu makroda kendime uyarlayacagim bölümler varmı acaba