İsme göre yeni çalışma kitabı oluşturmak

[Astalavista58]

Herkese merhabalar, küçük bir talebim olacaktı. Ekteki dosyada Sayfa1’i, Sayfa2’de “A” sütununda yazan isimlerle masaüstünde yeni bir klasör oluşturarak kaydetmek istiyorum. Yardımcı olabilirseniz çok mutlu olurum

 

[EmrExcel16]

Merhaba , deneyiniz..

Sub Farkli_Kaydet()
    Dim DsyYol , i
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    On Error Resume Next
    DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Emr"
    If Dir(DsyYol, vbDirectory) = "" Then MkDir (DsyYol)
     
    For i = 1 To Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
   
        If Sheets("Sayfa2").Cells(i, 1).Value <> "" Then
       
            Sheets("Sayfa1").Copy
            ActiveWorkbook.SaveAs DsyYol & "\" & ThisWorkbook.Sheets("Sayfa2").Cells(i, 1).Value
            ActiveWorkbook.Close SaveChanges:=False
           
        End If
       
    Next
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "islem tamam..."
   
End Sub

 

[Astalavista58]

Sayın EmreExcel16, elinize sağlık Allah razı olsun çok teşekkür ederim, çok güzel bir şekilde çalışıyor. Allah'a emanet olun

 

[EmrExcel16]

Sayın EmreExcel16, elinize sağlık Allah razı olsun çok teşekkür ederim, çok güzel bir şekilde çalışıyor. Allah'a emanet olun

Rica ederim , iyi çalışmalar..