Sayfaların Taşıındığı kitabın adı?

[hsayar]

Sub Tsb_Sayfalari_Tasi()
Dim sh As Worksheet
Dim i%, y%, x%, z%, w%
Dim arrsh(), arrShX()
Dim sayfalar As String
Mdl_00_Acls.DegiskenAl
Mdl_10_Sfr.SifreAc

z = UBound(ckBU_Klc_SfAd) + 1
w = Worksheets.Count

If z = w Then Exit Sub
y = 0
For Each sh In ThisWorkbook.Sheets
    For i = 0 To UBound(ckBU_Klc_SfAd)
        If sh.Name = ckBU_Klc_SfAd(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
'------------- SİLMEK İÇİN -----------------
'If UBound(arrShX) < 0 Then
'For i = 0 To UBound(arrShX)
     'sayfa = arrShX(i)
     Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
     [B]Sheets(arrShX).Move[/B]
     Application.DisplayAlerts = True   'ekrana mesaj vermeyi kapat
'Next i
'------------------------------------------------------
Mdl_10_Sfr.SifreKapa
End Sub

kodları ile sayfaların taşındığı kitabın adını öğrenmek için nasıl bir kod yazmam lazım?

Sheets(arrShX).Move bu tip kopyalama ile sadece sayfada sizin sayfalarınız oluyor

Çünkü aynı kitaba "Aylık","Devirler" sayfalarını kopyalamam lazım.

 

[hsayar]

sonradan aklıma geldi

'------------- TAŞIMAK İÇİN -----------------
     Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
     Sheets(arrShX).Move
     ActiveWorkbook.SaveAs "deneme"
     Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
'------------------------------------------------------

yapınca oluyor

 

[hsayar]

Sub Tsb_Sayfalari_Tasi()
Dim sh As Worksheet
Dim i%, y%, x%, z%, w%
Dim arrShX()
Dim sayfalar As String
Dim FSO As Object
Dim YnWb As Workbook
Dim MyFolder1, MyFolder2, MyFile, MyFileEnd As String
Call Mdl_00_Acls.DegiskenAl
Call Mdl_10_Sfr.SifreAc
Set FSO = CreateObject("Scripting.FileSystemObject")

MyFolder1 = ThisWorkbook.Path & Application.PathSeparator & Format(ckBU_sfAYL.Range("a1"), "yyyy")
    If Not FSO.FolderExists(MyFolder1) Then FSO.CreateFolder (MyFolder1)
  
MyFolder2 = MyFolder1 & Application.PathSeparator & Evaluate("=UPPER(""" & Format(ckBU_sfAYL.Range("a1"), "MMMM") & """)")
    If Not FSO.FolderExists(MyFolder2) Then FSO.CreateFolder (MyFolder2)

MyFile = Evaluate("=UPPER(""" & Format(ckBU_sfAYL.Range("a1"), "MMMM") & """)")
'YnWb = MyFolder2 & Application.PathSeparator & MyFile

z = UBound(ckBU_Klc_SfAd) + 1
w = Worksheets.Count

If z = w Then Exit Sub
y = 0
For Each sh In ThisWorkbook.Sheets
    For i = 0 To UBound(ckBU_Klc_SfAd)
        If sh.Name = ckBU_Klc_SfAd(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
'------------- TAŞIMAK İÇİN -----------------
     Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
     Sheets(arrShX).Move
     ActiveWorkbook.SaveAs MyFolder2 & Application.PathSeparator & MyFile
[B]     ckBU_sfAYL.Copy
     ckBU_sfDVR.Copy
[/B]     Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
'------------------------------------------------------
Mdl_10_Sfr.SifreKapa
End Sub

şu iki sayfayıda
ckBU_sfAYL.Copy: ckBU_sfDVR.Copy
Şu kitaba nasıl kopyalarım arkadaşlar yorumu olan varmı set edemedim bir türlü
ActiveWorkbook.SaveAs MyFolder2 & Application.PathSeparator & MyFile

 

[hsayar]

güncel....

Açık kitabı set etme nasıl olmalı