Açık Çalışma kitabını Set etme

[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, myyol 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
myyol = 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).Copy
[B]     ActiveWorkbook.SaveAs myyol              'istediğiniz yere kitabı farklı kaydettik.
     ActiveWorkbook.Close True                  'değişiklikleri kabul edip çıktık
     Set YnWb = Workbooks.Open(myyol & ".xls")       'yeniden açtık ve değişkene atadık.
[/B]
     ckBU_sfAYL.Copy after:=YnWb.Sheets(Sheets.Count)
     ckBU_sfDVR.Copy after:=YnWb.Sheets(Sheets.Count)
     Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
'------------------------------------------------------
Mdl_10_Sfr.SifreKapa
End Sub

kapatıp açmadan set etme yolu varmı acaba

 

[Zeki Gürsoy]

Ne yapmak istediğinizi tam anlamadım ama sanırım böyle birşey olmalı.

set Ynwb = activeworkbook.saveas (myyol & ".xls")
workbooks.open Ynwb

 

[hsayar]

alakanıza teşekkür ederim istediğimi buldum

'------------- TAŞIMAK İÇİN -----------------
     Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
     Sheets(arrShX).Copy:       ActiveWorkbook.SaveAs myyol
     Set YnWb = Workbooks(MyFile & ".xls")
     ckBU_sfAYL.Copy after:=YnWb.Sheets(Sheets.Count)
     ckBU_sfDVR.Copy after:=YnWb.Sheets(Sheets.Count)
     ActiveWorkbook.Close True
     Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
'------------------------------------------------------