Farklı Kaydet Makro for x döngüsü

[SSAFFAK]

Sub PDF()
Dim X As Byte

For X = 1 To 30
Range("L11") = X
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Desktop\" & X & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Next
End Sub

Hocalarım merhabalar; Yukarıdaki makroyu pdf olarak değilde "Excel" olarak dekstop üzerindeki "deneme" dosyasına aynen kaydettirmek istiyorum.
Nasıl yapmam konusunda yardımcı olabilirmisiniz. Dosya ektedir.

 

[SSAFFAK]

Değerli Hocalarım bu sorunu nasıl çözmem konusunda yardımcı olabilirmisiniz?

 

[SSAFFAK]

Ömer hocam benim derdime bir derman olabilirmisiniz? Bu işin içinden çıkamıyorum. Yukarıdaki pdf makrosunu pdf olarak değilde excel olarak dextop üstüne dosya açtırıp kaydettirmeye çalışıyorum. Fakat For X döngüsüyle yapmam lazım çünkü çok liste var. Son aşamasına geldim burada kaldım. Yardımlarınızı rica ediyorum hocam.

 

[Korhan Ayhan]

Deneyiniz.

Sub Sayfayi_Excel_Dosyasi_Olarak_Kaydet()
    Dim Yol As String, X As Byte
    
    On Error GoTo 10
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & "Deneme" & Application.PathSeparator
    
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
    
    For X = 1 To 30
        Range("L11") = X
        Calculate
        If Range("D6").Value <> 0 Then
            ActiveSheet.Copy
            Cells.Copy
            Cells(1, 1).PasteSpecial xlValues
            Cells(1, 1).Select
            On Error Resume Next
            ActiveSheet.DrawingObjects.Delete
            On Error GoTo 0
            ActiveWorkbook.SaveAs Yol & Range("D6").Value & ".xlsx", 51
            ActiveWorkbook.Close
        End If
    Next

10  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    MsgBox "Mesai fişleri aşağıdaki klasöre excel dosyası olarak kayıt edilmiştir." & vbCr & vbCr & Yol, vbInformation
End Sub

 

[SSAFFAK]

Korhan hocam çok yordum sizi hakkınızı helal edin. Hocam muhteşemsiniz. Biliyorum çok oldum ama son bir iyilik istesem sizden bu makroya; deneme dosyasının içine kayıt yaparken "excel adını" numara yerine mesai fişindeki isimleri baz alarak yani "mesai fişi D6 daki isme göre kayıt yaptırabilirmiyiz. Birde Mesai Fişi D6 boşsa kayıt yapmasın. (Yani 30 kişilik listede 25 kişi varsa 30 yerine o 25 kişiyi kayıt yapsın gibi.)

Korhan hocam siz başta olmak üzere bütün Excel Web hocalarıma çok ama çok teşekkür ederim. Hepinizden Allah razı olsun. Elleri öpülecek insanlarsınız. Sağolun. Varolun.

 

[Korhan Ayhan]

Kodu revize ettim.

Yalnız aynı İsim-Soyisim olan personel varsa üst üste kaydedeceğinden ilk dosya kaybolmuş olacaktır. Bir şekilde isimleri benzersiz yapmalısınız.

 

[SSAFFAK]

Evet hocam çok haklısınız. Aynı isim ve soyisimli kişileri ayrıca numarandiracağım. Hocam çok çok çok teşekkür ederim. Allah bin kere razı olsun.

 

[SSAFFAK]

Korhan Hocam kaydetme olayı yaklaşık 20 saniye sürüyor. Bunları tek excel içine koysak yani Mesai Fişin deki sayfalar "Liste" deki kişi sırasına göre alt alta sıralansa daha hızlı olurmu acaba? Böylelikle aynı isim ve soyisim sorunu da ortadan kalkmış olur.

 

[Korhan Ayhan]

Tek dosya içine aktarılabilir. Fakat hız olarak bir şey farketmeyebilir.

 

[SSAFFAK]

Korhan Hocam bugün epey başınızı ağrıttım biliyorum ama tek dosya olayı daha çok işimi kolaylaştıracak. Listedeki sıralamaya göre tek sayfaya toplamak için; Son olarak kodda nasıl bir düzenleme gerekir bu konuda da yardımcı olabilirmisiniz bana. Hocam birde excel ismini "MESAİ FİŞİ" ndeki C3 ten aldırabilirmiyiz. Elleriniz kollarınız dert görmesin hocam.

 

[Korhan Ayhan]

Tek dosyadaki sayfa isimleri ne olacak?

 

[SSAFFAK]

Hocam tek dosya içinde ve tek sayfa için de alt alta sıralanırsa çıktı almak için de kolaylık olacak. Yani tek bir excel içine yerleştirsek.
Tek sayfa ismini "C3" teki aylardan alırsa süper olacak.

 

[Korhan Ayhan]

Çıktı alacaksanız neden kaydetmeyle uğraşıyorsunuz? Direk yazıcıya gönderilebilir.

 

[SSAFFAK]

Hocam çıktı olayı farklı bir mevzu kaydetmekteki asıl amacım fişlerdeki deki farklı zamanlarda değişkenler olabilir. Öyle durumda manuel müdahale edilecek. O müdahaleleri kaydettiğimiz yerde yapacağız. Ondan dolayı tek excel sayfasının içinde olması işimizi daha çok hızlandıracak.

 

[Korhan Ayhan]

Bu tarz taleplerinizi ilk mesajınızda belirtmelisiniz. Hem siz zaman kaybı yaşamazsınız. Hem de bizler yaşamamış oluruz.

Deneyiniz.

Sub Sayfayi_Excel_Dosyasi_Olarak_Kaydet()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Yol As String, X As Long, Alan As Range
    Dim Dosya_Adi As String, Satir As Long
    
    On Error GoTo 10
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("MESAİ FİŞİ")
    
    Dosya_Adi = S1.Range("C3").Value
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & "Deneme" & Application.PathSeparator
    
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
    
    Set K2 = Workbooks.Add(1)
    Set S2 = K2.Sheets(1)
    
    Satir = 2
    
    For X = 1 To 30
        S1.Range("L11") = X
        Calculate
        If S1.Range("D6").Value <> 0 Then
            S1.Range("Print_Area").Copy S2.Cells(Satir, 2)
            Cells.Copy
            Cells(1, 1).PasteSpecial xlValues
            Satir = Satir + 52
        End If
    Next

    S1.Range("A:K").Copy
    S2.Range("A:K").PasteSpecial xlPasteColumnWidths

    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    
    For X = 2 To S2.Cells(S2.Rows.Count, 2).End(3).Row
        For Each Alan In S1.Range("B2:B52")
            S2.Cells(X, 2).RowHeight = Alan.RowHeight
            X = X + 1
        Next
    Next
    
    
    Cells(1, 1).Select
    
    ActiveWindow.View = xlPageBreakPreview
    S2.PageSetup.PrintArea = "$B$1:$K$" & S2.Cells(S2.Rows.Count, 2).End(3).Row
    
    Application.PrintCommunication = False
    With S2.PageSetup
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.196850393700787)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        .CenterHorizontally = True
        .CenterVertically = True
        .Zoom = 76
    End With
    Application.PrintCommunication = True
    
    
    For X = 53 To S2.Cells(S2.Rows.Count, 2).End(3).Row Step 52
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=S2.Cells(X, 2)
    Next
    
    ActiveWindow.View = xlNormalView
    
    ActiveWorkbook.SaveAs Yol & Dosya_Adi & ".xlsx", 51
    ActiveWorkbook.Close

10  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing

    MsgBox "Mesai fişleri aşağıdaki klasöre excel dosyası olarak kayıt edilmiştir." & vbCr & vbCr & Yol, vbInformation
End Sub

 

[SSAFFAK]

Hocam çok afedersiniz sağlık çalışanıyım dalgınlığıma gelmiş. Aslında ilk bu şekli anlatmaya çalışmıştım ama yanlış ifade ettim sanırım. Hocam bu son kod çalışmadı. Sadece mesajbox ekranı çıkıyor fakat açılan dosya yada excel sayfası yok. Tekrardan değerli vaktinizi aldığım için de çok özür dilerim.

 

[Korhan Ayhan]

Ben şimdi tekrar denedim. Masa üstünde "Deneme" isimli klasör oluşturup excel dosyasını içine sorunsuz kayıt ediyor. Sizin kendi uyguladığınız dosyanızda başka bir sorun olabilir.

 

[SSAFFAK]

Hocam sayfa içindeki bütün makroları sildim ve sizin kodu ekledim. Fakat çalıştırdığımda anında kayıt yapıldı Mesajbox ekranı çıkıyor. Ama masa üstünde hiç bişey yok. Nerede hata yapıyorum anlamadım.

 

[Korhan Ayhan]

İlk mesajda ki dosya üzerinde deniyorsunuz değil mi?

 

[SSAFFAK]

Evet hocam şimdi dediğinizi denedim olmadı.