Sayfaları başka kitaba kopyalama

[ÖZLÜCE]

Merhaba

Aşağıdaki kod, Sadece aktif sayfayı kopyalıyor.
Ben kitaptaki tüm sayfaları kopyalamasını istiyorum. Bu konuda yardımlarınızı bekliyorum. Teşekürler.

Private Sub excele_aktar_Click()

Application.EnableEvents = False

Dim Dosya_Sistemi As Object, Dosya_Yolu As String, Dosya_Adı As String
Dim VBComps As Object, VBComp As Object

Dosya_Adı = InputBox("DOSYA ADINI GİRİNİZ..", " EXCEL'E AKTAR")
If Dosya_Adı = "" Then Exit Sub

Dosya_Yolu = ThisWorkbook.Path & "\EXCEL"

Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")

If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
Dosya_Sistemi.CreateFolder (Dosya_Yolu)
End If

Application.ScreenUpdating = False

If Dir(Dosya_Yolu & Application.PathSeparator & Dosya_Adı & ".xls", vbNormal) = "" Then

ActiveSheet.Copy
On Error Resume Next
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0

Uyarıkapat

ActiveWorkbook.SaveAs Filename:=Dosya_Yolu & Application.PathSeparator & Dosya_Adı & ".xls"

Set VBComps = ActiveWorkbook.VBProject.VBComponents

For Each VBComp In VBComps
Select Case VBComp.Type
Case 100
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Case Else
VBComps.Remove VBComp
End Select
Next VBComp

Set VBComps = Nothing

ActiveWorkbook.Close 0

Application.ScreenUpdating = True

MsgBox "Yedekleme işlemi tamamlanmışır.", vbInformation
Else
MsgBox "Yedekleme işlemi iptal edilmiştir !", vbExclamation
End If
Set Dosya_Sistemi = Nothing
Set VBComps = Nothing

Uyarıaç
Application.EnableEvents = True

End Sub

 

[halit3]

Aşağıdaki linkdeki dosyaya bir bakınz.?


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

 

[ÖZLÜCE]

Sağolun, İlginize teşekkür ederim.

 

[halit3]

Sağolun, İlginize teşekkür ederim.

İyi çalışmalar

 

[canerbulut]

ismi yazılı sayfaları taşıyarak kopyalama

üstadım merhabalar... 2010 versiyonu ile eklediğim dosyada POZ_LİSTESİ sayfasının B sütununda ismi yazılı sayfaları başka bir çalışma kitabına kopyalanarak taşınsın istiyorum.. yardımcı olabilirmisiniz. şimdiden teşekkürler..

 

[halit3]

üstadım merhabalar... 2010 versiyonu ile eklediğim dosyada POZ_LİSTESİ sayfasının B sütununda ismi yazılı sayfaları başka bir çalışma kitabına kopyalanarak taşınsın istiyorum.. yardımcı olabilirmisiniz. şimdiden teşekkürler..

Poz_listesi sayfasında B sutunundaki kapyalayıp taşıyacağın sayfalar için A sutununa 1 (bir) sayısını yaz ve kodu dene

Sub dosyaolustur()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
a = Application.FindFile
If a = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
yeni_dosya_adı = ActiveWorkbook.Name
Windows(dosya_adı).Activate
j = 0
For i = 1 To Sheets.Count
r = 0
For n = 3 To Worksheets("POZ_LİSTESİ").Cells(Rows.Count, "B").End(3).Row
If Worksheets("POZ_LİSTESİ").Cells(n, 1).Value = 1 Then
If Worksheets("POZ_LİSTESİ").Cells(n, 2).Value = Sheets(i).Name Then
r = 1
Exit For
End If
End If
Next
If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select
 
Sheets(1).Activate
Sheets(myArray).Copy Before:=Workbooks(yeni_dosya_adı).Sheets(1)
Windows(yeni_dosya_adı).Activate
ActiveWorkbook.Save
ActiveWindow.Close
Windows(dosya_adı).Activate
Sheets(Sayfa_Adı).Select
ActiveWindow.WindowState = xlMaximized
MsgBox "işlem tamam"
End Sub

not: kodun çalışması için A sutununa 1 yazılacak ve B sutunundaki yazılı sayfa ismi dosyanın içinde var olacak

 

[canerbulut]

üstadım elinize kolunuza sağlık süper olmuş... bu siteyi arkadaşlar muhteşem vallalhi... çok teşekkür ediyorum.....

 

[halit3]

üstadım elinize kolunuza sağlık süper olmuş... bu siteyi arkadaşlar muhteşem vallalhi... çok teşekkür ediyorum.....

İyi çalışmalar

 

[canerbulut]

üstadlarım ekli dosyada " AKTARMA" SAYFASINDA açıklamalar yazılı... dosya belli bir seviyeye gelmiştir. sadece istediklerimi yaptırıken biraz fazla satır yazmakta... onları elle silmek zorunda kaliyorum.. tam çalışması konusunda yardımlarınızı bekliyorum... şimdiden elinize sağlık...

 

[halit3]

üstadlarım ekli dosyada " AKTARMA" SAYFASINDA açıklamalar yazılı... dosya belli bir seviyeye gelmiştir. sadece istediklerimi yaptırıken biraz fazla satır yazmakta... onları elle silmek zorunda kaliyorum.. tam çalışması konusunda yardımlarınızı bekliyorum... şimdiden elinize sağlık...

Konu bütünlüğü bozulmaması için Sorunuzu yeni bir konu açarak başka bir başlık altında sorun