Kapalı Dosyaları Tek Bir Kitapta Birleştirme

[BedriA]

Sürücü yolu için A2 hücresine

ThisWorkbook.Path & "\KOPYA\"

yazınca çalışmıyor. Her bilgisayarda çalışacak şekilde ayarlamak mümkün mü?

 

[BedriA]

Çok teşekkür ederim Asri Hocam.
Son soruma gerek kalmadı bu kod ile sanırım.

Selam ve saygılarımla.

 

[halit3]

Alternatif kod

Dim dosya_adı
Dim yeni_dosya_adı
Dim dosya_adı2
Dim say1
Sub Klasördeki_Dosyaların_Bütün_Sayfalarını_Taşıyarak_Bu_Dosyaya_Kopyala2()

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

dosya_adı = ActiveWorkbook.Name
Liste4 (Klasor.Items.Item.Path)
Workbooks(dosya_adı2).Sheets(Sheets(1).Name).Select
Application.CutCopyMode = False

For Each ModX In Workbooks(dosya_adı2).VBProject.VBComponents
Set VBComp = Workbooks(dosya_adı2).VBProject.VBComponents(ModX.Name)

If ModX.Type = 100 Then
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
Else
Workbooks(dosya_adı2).VBProject.VBComponents.Remove VBComp
End If
Next

aranan_Uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(Application.AddIns.Item(1).FullName)

If aranan_Uzanti = "xlam" Then
FileFormatNum = 52
uzanti2 = "xlsm"
End If
If aranan_Uzanti = "xla" Then
FileFormatNum = -4143
uzanti2 = "xls"
End If

sat1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
dosyaadi1 = "Dosya" & sat1 & "." & uzanti2

Workbooks(dosya_adı2).SaveAs Filename:=ThisWorkbook.Path & "\" & dosyaadi1, FileFormat:=FileFormatNum
Workbooks(dosyaadi1).Close SaveChanges:=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 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)

yeni_dosya_adı = ActiveWorkbook.Name


For i = 1 To Workbooks(yeni_dosya_adı).Sheets.Count
Application.DisplayAlerts = False
say1 = say1 + 1

If say1 = 1 Then
Workbooks(yeni_dosya_adı).Sheets(i).Copy
dosya_adı2 = ActiveWorkbook.Name
say = Workbooks(dosya_adı2).Sheets.Count
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Move After:=Workbooks(dosya_adı2).Sheets(say)
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Name = "Sayfa" & say


Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).DrawingObjects.Delete
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Cells.Copy
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Range("A1").PasteSpecial Paste:=3
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Range("A1").Select

Else
Workbooks(yeni_dosya_adı).Sheets(i).Copy After:=Workbooks(dosya_adı2).Sheets(1)
say = Workbooks(dosya_adı2).Sheets.Count
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Move After:=Workbooks(dosya_adı2).Sheets(say)
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Name = "Sayfa" & say


Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).DrawingObjects.Delete
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Cells.Copy
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Range("A1").PasteSpecial Paste:=3
Workbooks(dosya_adı2).Sheets(ActiveSheet.Name).Range("A1").Select

End If

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]

Çok teşekkür ederim Halit Hocam.