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

[SSAFFAK]

Önceki makronuzu ekliyorum çalışıyor. O kodu silip son makroyu yapıştırıyorum olmuyor.

 

[Korhan Ayhan]

Ekli dosya bende sonuç veriyor.

Ürettiği sonuç dosyasını da paylaşıyorum.

 

[SSAFFAK]

Hocam çok komik bir durum benim bilgisayarda olmuyor kafayı yiyecem.

 

[SSAFFAK]

Korhan hocam başka pc de denedim yine olmuyor. Kaydetme yeri olarak mı bir hata var acaba.?

 

[Korhan Ayhan]

Kodu F8 tuşu ile adım adım çalıştırın.

Kodun başında ki On Error GoTo 10 satırını silin ve kodu F8 tuşu ile adım adım çalıştırın.

Eğer bir satırda hata oluşuyorsa buraya yazın üzerinde düşünelim ve çözüm üretmeye çalışalım.

 

[SSAFFAK]

Korhan Hocam tekrardan merhabalar. F8 ile çalıştırdığımda Sub sonrasındaki Dimleri es geçiyor ve Dosya adına gelince aşağıdaki hatayı veriyor.

 

[Korhan Ayhan]

MESAİ FİŞİ C3 hücresinde ne yazıyor?

 

[SSAFFAK]

Hocam Ay adı "OCAK-ŞUBAT" yazıyor.

 

[SSAFFAK]

Hocam bişey farkettim bu kodu işyeri dışındaki başka pc de denedim çalıştı. İşyeri bilgisayarı türkçe excel acaba ondan olabilirmi?

 

[Korhan Ayhan]

Bende TÜRKÇE kullanıyorum. Sorun çıkarmıyor.

 

[SSAFFAK]

Hocam Normalde kayıt yaparken biraz bekliyor tamamlandıktan sonra mesaj box ekranı çıkıyor. Fakat bu bilgisayarada çalıştırdığımda anında kayıt yapıldı mesajbox penceresi çıkıyor fakat masa üstünde hiç bişey yok.

 

[Korhan Ayhan]

Kod bende çalışıyor. Siz de bir bilgisayarda çalışıyor diyorsunuz. Bu durumda kod da bir problem olduğunu düşünmüyorum.

Ben exceli hem TÜRKÇE hem de İNGİLİZCE kullanıyorum.

İki dilde tekrar denedim. İkisinde de sorun çıkmadı.

Bu arada işletim sistemim İNGİLİZCE'dir.

 

[SSAFFAK]

Peki hocam bu kayıt yapılan excellerin içerisindeki kılavuz çizgilerini ve sıfırları nasıl kaldırabiliriz? Hocam uğraştırıcı bişeyse olmazsa da olur çok yük oldum size biliyorum.

 

[Korhan Ayhan]

Bu tarz kodları sizde MAKRO KAYDET yöntemi ile elde edip önerdiğimiz kodlara uyarlayabilirsiniz. Hem böylece makro yazmaya adım atmış olursunuz.

 

[SSAFFAK]

Tamamdır Hocam kodun hangi aralığına yerleştirmem gerektiğini bilemedim ondan dolayı sormuştum. Canınız sağolsun. Emeğiniz büyüktür hocam çok yardımlarınız oldu hakkınızı helal ediniz. elinize ve emeğinize sağlık..

 

[Korhan Ayhan]

Hakkım varsa helal olsun..

 

[SSAFFAK]

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 & "MESAİ FİŞLERİ" & 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
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayZeros = False
  
    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.DisplayGridlines = False
    ActiveWindow.DisplayZeros = False
    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

Hocam yukarıdaki kodu birazcık değiştirdim. Fakat YOL kısmında yapmam gereken değişikliği bi türlü beceremedim. Şöyleki dekstop üzerine yeni klasör açarken "mesailer" isimli bir klasör açıp içerisine tekrar yeni klasör açarak adını "C4" ten alacak, onunda içine yeni klasör açarak adınıda "C3" ten alarak buraya kayıt yapması için kodda nasıl bir değişiklik yapmam gerektiğini bir türlü beceremedim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

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, Ayirac As String
    
    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
    
    Ayirac = Application.PathSeparator
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Ayirac & "Mesailer" & Ayirac & _
          S1.Range("C4").Value & Ayirac & S1.Range("C3").Value & Ayirac
    
    If Dir(Yol, vbDirectory) = "" Then CreateObject("WScript.Shell").Run "Cmd /C MkDir """ & Yol & """", 0, True
    
    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
    
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayZeros = False
    
    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]

Hocalarım merhabalar; bu kod özel bilgisayarımda çalışıyor ama işyeri bilgisayarımda Dosya Adı kısmında hata veriyor.
Bu sorunun neden kaynaklanabileceği hakkında fikir verebilecek var mıdır acaba?

 

[Korhan Ayhan]

C3 hücresindeki değeri denemek amaçlı OCAK-SUBAT olarak düzenleyerek kodu deneyiniz. Eğer sorun Türkçe karakterlerden kaynaklanıyorsa kodu revize ederiz.