çalışma kitabımdaki sayfaları başka kitaplara aktarmak.

[kucukdunyam]

merhabalar, çalışma kitabımda farklı farklı isimlerde 21 tane sayfa mevcut, ayrıca aynı klasörün içinde 21 tane daha excel dosyam var, bu sayfaları bu dosyalara kopyalamak istiyorum, örneğin Sayfa1'i, Setbaşı.xls dosyasının içine, Sayfa2'yi Uludağ.xls dosyasının içine ....... sayfa olarak kopyalamak istiyorum. Bunun için yardımcı olabilirmisiniz.

 

[omerceri]

Manuel:
Her iki kitap açık iken kopyalanacak sayfa sekmesinin üzerinde sağ tıklayın, çıkan listeden "Taşı veya Kopyala" seçin, Kitap yazan bölümde diğer kitabı seçin, aşağıdaki Kopya oluştur u onaylayın ve tamama tıklayın.
Kod ile yapılabilinmesi için hangi sayfanın hangi kitaba kopyalanacağını belirlenmiş olması lazım sorunuzda bu konuda bir veri yok örneğin Setbaşı sayfası Setbaşı.xls ye veya Sayfa1 bu sayfanın A1 hücresinde yazılı kitaba gibi

 

[kucukdunyam]

aradığım çözümü buldum,
Option Explicit
Sub aktar()
Dim XCL As Application, KTP As Workbook
Dim S1 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False


Set S1 = Sheets(3)
Set KTP = Workbooks.Open("D:\rapor.xls")
S1.Copy after:=KTP.Sheets(KTP.Sheets.Count)
KTP.Save: KTP.Close

Set S1 = Sheets(3)
Set KTP = Workbooks.Open("D:\rapor1.xls")
S1.Copy after:=KTP.Sheets(KTP.Sheets.Count)
KTP.Save: KTP.Close


Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub



'ancak burada kopyalamak istediğim sayfa formüllü, ancak ben değerleri yapıştırmak istiyorum, bu kodu nasıl düzeltebilirim,

 

[halit3]

Alternatif olarak aşağıdaki linkdeki dosyaya bakınız.

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

 

[kucukdunyam]

çok teşekkür ederim de, çalışırken şu satırlarda hata veriyor
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

office 2010 kullanıyorum

 

[halit3]

çok teşekkür ederim de, çalışırken şu satırlarda hata veriyor
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

office 2010 kullanıyorum

(Private Declare) bununla başlayan bölümlere (PtrSafe) bunu eklemelisiniz yani aşağıdaki kırmızı bölüm gibi olacak

Private Declare [COLOR="Red"]PtrSafe[/COLOR] Function

 

[kucukdunyam]

tekrar bir soru sormak isterim, ancak hangi konuya soracağımı bilemiyorum. o yüzden buraya yazıyorum,

eklediğim dosyanın içindeki kodu değiştirmek istiyorum,

125k daireye gönder.xlsm nin içinde aktar sayfası var. buradaki makroyu çalıştırdığımda 1. satırdaki verileri (göstereceğim klasörün içindeki dosyalardan sayfa adı olarak arayıp, bu sayfaları kopyalayarak bir dosya oluşturuyor. bu işi yaparken B1 hücresini atlıyor. yani buradaki veriye de bakmasını istiyorum. birde dosya oluşturma safhasında excel kapatılıyor hatası alıyorum.
yardımca olacağınız için çok teşekkür ederim.

 

[kucukdunyam]

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Dim sat As String
Sub sayfaları_buraya_taşı()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
sat = 0
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
Call Liste(Kaynak, "")
MsgBox "işlem tamam"
deger = Sheets("Aktar").Range("a1")
ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\" & deger), FileFormat:=56
Application.DisplayAlerts = False
Sheets("Aktar").Delete
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
Do While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Klasor & "\" & Dosya)
sıra = Sheets.Count
yenidosya_adı = ActiveWorkbook.Name
For r = 1 To sıra
Sheets(r).Select
aranan = ActiveSheet.Name
bulunan = 0
For j = 1 To ThisWorkbook.Sheets(Sayfa_Adı).Range("a1:AP1").Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, j) = aranan Then
bulunan = 1
End If
Next j
If bulunan = 1 Then
Sheets(Sheets(r).Name).Select
Sheets(Sheets(r).Name).Copy Before:=Workbooks(dosya_adı).Sheets(1)
Sheets(ActiveSheet.Name).Select
If Sheets(ActiveSheet.Name).Cells(2, 12).Value <> "" Then
ekle = Sheets(ActiveSheet.Name).Cells(2, 12).Value
Else
sat = sat + 1
ekle = sat + 1000
End If
End If
Windows(yenidosya_adı).Activate
Next r
wb.Close False
Application.Visible = True

End If
Dosya = Dir
Loop
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path

Call Liste(Kaynak, "")
sonraki:
Next

Set fL = Nothing
End Sub