oluşturulan dosyayı sormadan masa üstüne atması

[numan şamil]

kodlarda nereyi değiştirmem gerekiyor Yardım!

Merhaba arkadaşlar
oluşturduğum dosyayı masa üstünde bulunan "oluşturulan klosör" adlı klosörün içine sormadan atması için
aşağıdaki kodlarda nereyi değiştirmem gerekiyor?
Sub çalışmakitabıyap()
deger = Range("a2").Value
deger1 = ("sayfa1")
'dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
Kaynak = Klasor.SELF.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
If Right(Kaynak, 1) = "\" Then
Kaynak = Kaynak
Else
Kaynak = Kaynak & "\"
End If
On Error Resume Next
Dim sayfa As Worksheet
For Each sayfa In Worksheets
MsgBox Worksheets
If sayfa.Name = Sayfa_Adı Then
Sayfa1.Copy
Sheets(ActiveSheet.Name).Name = deger1
ActiveWorkbook.SaveAs Kaynak & deger & Uzanti
ActiveWorkbook.Close False
Exit Sub
End If
Next sayfa
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kod aktif sayfanızı A2 hücresindeki isimle dosya olarak belirttiğiniz klasöre sorgusuz kayıt eder.

Option Explicit
 
Sub AKTİF_SAYFAYI_DOSYA_OLARAK_KAYDET()
    Dim Dosya_Sistemi As Object, Klasör As String
    Dim Kitap_Adı As String, Dosya_Yolu As String, Dosya_Adı As String
    
    Application.ScreenUpdating = False
    
    Kitap_Adı = Range("A2").Value & ".xls"
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\"
    
    
    If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
        Dosya_Sistemi.CreateFolder (Dosya_Yolu)
    End If
    
    Dosya_Adı = Dosya_Yolu & Kitap_Adı
    ActiveSheet.Copy
    ActiveSheet.Name = "Sayfa1"
    
    Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\" & Kitap_Adı
    
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Dosya_Yolu
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[numan şamil]

Merhaba korhan bey
göndermiş olduğunuz kodları dosyama uyarlamaya çalıştım
1)kitap ismini A2 hücresinde alması gerekiyor bu tamam
2) sayfa1' oluşturulan klosöre atması gerekiyordu bunuda ActiveSheet.copy kısmını Sayfa1.copy olarak değiştirdi oda tamam oldu

ufak bir sorun var aktar sayfasındaki (yani kitap ismini A2 hücresinden aldığı sayfa) dolu satırlar bittiği halde "TÜMÜ" butonuna basmaya devam edince hata veriyor kodlarda ActiveWorkbook.SaveAS Dosya_Yolu sarıya boyanıyor bunu nasıl önleriz
Ayrıca hocam aktar sayfasındaki "TÜMÜ" butonuna bir kere bastığımızda bu düğmenin yaptığı işlemleri dolu satırlar bitene kadar tekrar edip dolu satır bitince sona erecek gibi modüle 5' nasıl düzenleriz
Ekli dosyayı inceleye bilirmisiniz
Teşekkür ederim iyi çalışmalar

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu TÜMÜ butonuna atadığınız makroların yerine kullanabilirsiniz. Tüm işlemleri aynı anda yapmaktadır.

Option Explicit
 
Sub AktifSayfayıÇalışmaKitabıOlarakKaydet()
    Dim Dosya_Sistemi As Object, Klasör As String
    Dim Kitap_Adı As String, Dosya_Yolu As String, Dosya_Adı As String
    Dim X As Long, S1 As Worksheet, S2 As Worksheet
    
    Set S1 = Worksheets("Aktar")
    Set S2 = Worksheets("Sayfa1")
    
    If WorksheetFunction.CountA(S1.Range("A:A")) = 0 Then
        MsgBox "Aktarım yapılacak veri bulunamadı !", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\"
    
    If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
        Dosya_Sistemi.CreateFolder (Dosya_Yolu)
    End If
    
    
    For X = 2 To S1.Range("A65536").End(3).Row
        S2.Range("P9") = S1.Range("C2")
        S2.Range("AD47") = S1.Range("D2")
        S2.Range("AH47") = S1.Range("E2")
        S2.Range("AN47") = S1.Range("F2")
        S2.Range("AU47") = S1.Range("G2")
        S2.Range("J32") = S1.Range("H2")
        S2.Range("J33") = S1.Range("I2")
        S2.Range("J34") = S1.Range("J2")
    
        Kitap_Adı = S1.Cells(X, 1) & ".xls"
        Dosya_Adı = Dosya_Yolu & Kitap_Adı
        S2.Copy
        ActiveSheet.Name = "Sayfa1"
        
        Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\" & Kitap_Adı
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Dosya_Yolu
        ActiveWorkbook.Close False
        Application.DisplayAlerts = True
    Next
    
    S1.Range("A2:J65536").ClearContents
    
    Set Dosya_Sistemi = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[numan şamil]

Çok teşekkür ederim hocam
Allah sizden razı olsun