Başka dosyaya sayfa kopyalamak

[numan şamil]

Merhaba Arkadaşlar
Ekli Örnek1 dosyası gibi bir dosyam var
Aktar butonuna bastığımda masa üstünde EXCEL adli klasör oluşturuyor
Ekli EXCEL.zip dosya gibi
Ben bu şekilde değil de ekli EXCEL1.zip dosyası gibi klasör oluşturmasını istiyorum
Yardımlarınızı bekliyorum
Not değiştirilecek kod

Sub Dosyaoluşturozel()
Dim Dosya_Sistemi As Object, Klasör As String
    Dim Kitap_Adı As String, Dosya_Yolu As String, Dosya_Adı As String
    Dim S1 As Worksheet, S2 As Worksheet
    Set S1 = Sheets("Sayfa1")
    Set S2 = Worksheets("TASLAK")
    Application.ScreenUpdating = False
   
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL\"
    If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
       Dosya_Sistemi.CreateFolder (Dosya_Yolu)
    End If
     Kitap_Adı = S2.Range("A2").Value & ".xlsx"
        Dosya_Adı = Dosya_Yolu & Kitap_Adı
        S2.Copy
         ActiveSheet.Name = S2.Range("A2").Value
        Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL\" & Kitap_Adı
   
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Dosya_Yolu
        ActiveWorkbook.Close False
        Application.DisplayAlerts = True
    Set Dosya_Sistemi = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   Application.ScreenUpdating = True
End Sub

 

[ÖmerFaruk]

Makro kaydet yöntemiyle doğru sonuçları elde edebilrisiniz.
Ben basitçe Taslak isimli sayfanızı makro kaydet ile yeni çalışma kitabı olarak Downloads klasörümün altına kaydettim.

    Sheets("TASLAK").Select
    Sheets("TASLAK").Copy
    ChDir "C:\Users\cakma\Downloads"
    ActiveWorkbook.SaveAs Filename:="C:\Users\cakma\Downloads\deneme1.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

 

[numan şamil]

Merhaba
1 nolu mesajdaki Ekli dosyalarda
EXCEL1.zip dosyası yanlış olmuş yeniden güncellendi.
Ayrıca her bilgisayarda çalışacak şekilde masa üstüne "EXCEL" adlı klasör açıp
içerisine" DENEME" adlı kitap açıp bu kitap içerisinde TASLAK adlı sayfayı kopyalaması
sayfa ismini TASLAK adlı sayfadaki A2 hücresinde yazan ismi alması
Taslak adlı sayfa veriler aktar1 ve aktar2 makroları ile değişiyor
Kısaca:
Bur da EXCEL.zip deki gibi ayrı ayrı kitap şeklinde değil de EXCEL1 deki gibi DENEME adlı kitap içerisnde ayrı ayrı sayfalar oluşturulması
umarım anlata bilmişimdir

 

[Korhan Ayhan]

Merhaba,

Eski kodları silip bu kodu deneyiniz. TASLAK sayfasına ihtiyaç kalmadı.

Option Explicit

Sub Created_File()
    Dim FSO As Object, File_Path As String, S1 As Worksheet, WB As Workbook
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    File_Path = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL\"
    
    If Not FSO.FolderExists(File_Path) Then
       FSO.CreateFolder (File_Path)
    End If
    
    Set S1 = Sheets("Sayfa1")
    
    With S1.Range("C3:C5")
        .Formula = "=A3*B3"
        .Value = .Value
    End With
    
    With S1.Range("C9:C10")
        .Formula = "=A9*B9"
        .Value = .Value
    End With
    
    Set WB = Workbooks.Add(xlWBATWorksheet)
    
    WB.Sheets.Add After:=WB.Sheets(WB.Sheets.Count)

    WB.Sheets(1).Range("A2").Value = S1.Range("A2").Value
    WB.Sheets(1).Range("A3:A5").Value = S1.Range("C3:C5").Value
    WB.Sheets(1).Name = S1.Range("A2").Value

    WB.Sheets(2).Range("A2").Value = S1.Range("A7").Value
    WB.Sheets(2).Range("A3:A4").Value = S1.Range("C9:C10").Value
    WB.Sheets(2).Name = S1.Range("A7").Value
    
    WB.Sheets(1).Select
    
    WB.SaveAs File_Path & "DENEME", xlOpenXMLWorkbookMacroEnabled
    WB.Close
    
    Set S1 = Nothing
    Set WB = Nothing
    Set FSO = Nothing
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "Veri dosyası aşağıdaki klasöre oluşturulmuştur." & _
           vbCrLf & vbCrLf & File_Path & "DENEME.xlsm", vbInformation
End Sub

 

[numan şamil]

Merhaba Korhan Bey
İlginiz için teşekkür ederim.
Taslak Sayfası kalmak zorunda veriler dinamik vaziyette gelmektedir
örnekteki Aktar1 ve Aktar2 kodları birer basit örnek esas kodlar farklı benim istediğim makro çalışırken taslak sayfasına göre birebir
sayfa eklemesi gerekiyor .Ekleyeceği sayfaya ismini verecek olan taslak sayfasındaki A2 hücresindeki veri değişiyor aynı isim olmuyor
Tam olarak istediğim Dosya_oluştur_ozel (makro adı önemli değil) kodlar arsına ekleyeceğim sırası gelince Taslak sayfasını bire bir kopyalayıp taslak sayfasının A2 hücresindeki isme göre (oluşturduğu klasör içerisindeki deneme dosyasına) sayfa ekleyerek devam etmesi

 

[halit3]

Bu kodu bir dene

Sub Dosyaoluşturozel()

Dim Klasör As String
Dim Kitap_Adı As String, Dosya_Yolu As String, Dosya_Adı As String, isim As String
Dim S2 As Worksheet

Set S2 = Worksheets("TASLAK")
Application.ScreenUpdating = False

isim = S2.Range("A2").Value

Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL"
If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) = False Then
MkDir Dosya_Yolu
End If
    

Kitap_Adı = isim & ".xlsx"
Dosya_Adı = Dosya_Yolu & "\" & Kitap_Adı
S2.Copy
ActiveSheet.Name = isim

Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL\" & Kitap_Adı
    
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Dosya_Yolu
ActiveWorkbook.Close False
Application.DisplayAlerts = True


Set S2 = Nothing
Application.ScreenUpdating = True
End Sub

 

[numan şamil]

Merhaba Halit Bey
Cevabınız İçin teşekkürler
Kodunuzu denedim Excel klasörü içerisinde ayrı ayrı
Örneğin Ali ve Hasan adlı kitap oluşturuyor
Kitap_Adı = "DENEME" & ".xlsx"
Şeklinde Yaptığımda DENEME adlı kitap oluşturup
Sadece Hasan adlı sayfa oluşturuyor, Ali adlı sayfa eklenmiyor
Benim istediğim
DENEME adlı bir tane kitap bu kitabın içinde (örneğe göre) Hasan ve Ali adlı sayfaları oluşturması
Yani sizin kodlarınızın ayrı ayrı oluşturduğu Ali ve Hasan dosyaları DENEME adlı dosya içerisinde (Ali Ve Hasan dosyalarını) sayfa olarak oluşturması ekli dosyadaki gibi
Oluşturulan Klasörde sadece DENEME adlı kitap olacak

 

[halit3]

kod

Sub Hesapla_Dosyala()
Call hesapla
Call Aktar1
Call Aktar2
Sheets("Sayfa1").Select
MsgBox "işlem tamam"

End Sub
Sub hesapla()
Dim S1 As Worksheet
Set S1 = Sheets("Sayfa1")
S1.Range("C3:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
         S1.Range("C3").Value = S1.Range("A3").Value * S1.Range("B3").Value
        S1.Range("C4").Value = S1.Range("A4").Value * S1.Range("B4").Value
      S1.Range("C5").Value = S1.Range("A5").Value * S1.Range("B5").Value
     S1.Range("C9").Value = S1.Range("A9").Value * S1.Range("B9").Value
    S1.Range("C10").Value = S1.Range("A10").Value * S1.Range("B10").Value
    Application.ScreenUpdating = False
End Sub
Sub Aktar1()
Dim S1 As Worksheet, S2 As Worksheet
Dim sat1 As Long, sat2 As Long, i As Long
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("TASLAK")
S2.Range("C3:C5").ClearContents
Application.ScreenUpdating = False
S2.Range("A2").Value = S1.Range("A2").Value
         S2.Range("A3").Value = S1.Range("C3").Value
        S2.Range("A4").Value = S1.Range("C4").Value
      S2.Range("A5").Value = S1.Range("C5").Value
    Application.ScreenUpdating = False
    Call Dosyaoluşturozel
  S2.Range("A2:C10").ClearContents
End Sub
Sub Aktar2()
Dim S1 As Worksheet, S2 As Worksheet
Dim sat1 As Long, sat2 As Long, i As Long
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("TASLAK")
S2.Range("C9:C10").ClearContents
Application.ScreenUpdating = False
S2.Range("A2").Value = S1.Range("A7").Value
         S2.Range("A3").Value = S1.Range("C9").Value
        S2.Range("A4").Value = S1.Range("C10").Value
    Application.ScreenUpdating = False
    Call Dosyaoluşturozel
   S2.Range("A2:C10").ClearContents
End Sub
Sub Dosyaoluşturozel()


Dim Kitap_Adı As String, Dosya_Yolu As String, isim As String, Sayfa_Adı As String, yeni_dosya_adı As String, eski_dosya_adı As String
Dim son As Long, say As Long

Dim S2 As Worksheet

Set S2 = Worksheets("TASLAK")
Application.ScreenUpdating = False

isim = S2.Range("A2").Value

eski_dosya_adı = ActiveWorkbook.Name

Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\EXCEL"
If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) = False Then
MkDir Dosya_Yolu
End If
Sayfa_Adı = "DENEME.xlsx"
 
Kitap_Adı = Dosya_Yolu & "\" & Sayfa_Adı

If CreateObject("Scripting.FileSystemObject").FileExists(Kitap_Adı) = True Then

Sheets("TASLAK").Select
Workbooks.Open Filename:=Kitap_Adı
yeni_dosya_adı = ActiveWorkbook.Name
son = ActiveWorkbook.Sheets.Count
Windows(eski_dosya_adı).Activate

Sheets("TASLAK").Copy After:=Workbooks("DENEME.xlsx").Sheets(son)

Application.DisplayAlerts = False
say = 0
For i = 1 To ActiveWorkbook.Sheets.Count
If isim = Left(ActiveWorkbook.Worksheets(i).Name, Len(isim)) Then
say = say + 1
End If
Next

If say > 0 Then isim = isim & say

ActiveSheet.Name = isim


Sheets(1).Select

ActiveWorkbook.SaveAs Kitap_Adı
ActiveWorkbook.Close False
Application.DisplayAlerts = True

Else

S2.Copy
Application.DisplayAlerts = False
ActiveSheet.Name = isim
yeni_dosya_adı = ActiveWorkbook.Name
Windows(yeni_dosya_adı).Activate
ActiveWorkbook.SaveAs Filename:=Dosya_Yolu & "\" & Sayfa_Adı, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close

Application.DisplayAlerts = True
End If

Set S2 = Nothing
Application.ScreenUpdating = True

MsgBox "işlem yapıldı"
End Sub

 

[numan şamil]

İyi Geceler Halit Bey
Çok Teşekkürler
Tam İstediğim gibi olmuş
Hakkını Helal et