Sadece dolu sayfaların yazdırılması..

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Değerli arkadaşlar..! A.I aralığında 800 satırı aşan tablo biçiminde 23 sayfa mevcut.. Her defasında sayfa sayısını belirleyerek yazdırma yerine, bir buton üzerinden, sadece dolu sayfaları yazdırmak.. Forumda aradığım örnekler istediğim gibi olmadı. İstediğim şu; G sütununu esas alarak, sadece dolu hücre gördüğü yere kadar (G sütununda) uzanan sayfaları yazdıran makro kodu gerekiyor..
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyanızın küçük bir örneğini eklemeniz mümkün mü?
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Korhan hocam..! Dosyanın tamamını ekliyorum.. İçerisindeki makroların bir çoğu sizin yazdığınız veya sizden uyarladığım kodlar.. Takıldığım veya düşündüğüm yerleri dosyada açıkladım..
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Yazdırma işlemini aşağıdaki kod ile yapabilirsiniz.

Kod:
Option Explicit

Sub Veri_Olan_Sayfalari_Yazdir()
    Dim S1 As Worksheet, Yazdirma_Alani As String, Son As Long
    
    Set S1 = Sheets("girdi")
    
    Yazdirma_Alani = S1.PageSetup.PrintArea

    Son = S1.Cells(S1.Rows.Count, "G").End(3).Row
    
    S1.PageSetup.PrintArea = "$A$1:$I$" & Son
    
    S1.PrintOut
    
    S1.PageSetup.PrintArea = Yazdirma_Alani
    
    Set S1 = Nothing
    
    MsgBox "Yazdırma işlemi tamamlanmıştır.", vbInformation
End Sub
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Diğer sorunuz için sayfaya ait kodu aşağıdaki gibi değiştirip deneyiniz.

Kod:
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub
If WorksheetFunction.CountA(Target) = 0 Then Exit Sub 'Delete ile form açma kaldırıldı..

If Intersect(Target, Range("A18:I" & Rows.Count)) Is Nothing Then Exit Sub 'A18:I sonrası kullanımda..
'If Intersect(Target, Range("C18:C5000")) Is Nothing Then Exit Sub
If Not Intersect(Target, Range("C18:C5000")) Is Nothing Then 'girdi kayıtları sınır alanı..
'/////////////////////////////////////////////////////////////////////////////////////////////////////

If Not UserForm1.ListBox1.Tag = "off" Then 'listbox'a, repertuvar'dan alınan veri alanı..
        
Dim deger As Range
sayac = 0
derlenen = Target.Address
            
bakilan = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
            
For Each deger In Sheets("RepertuvaR").Range("C2:C5000")
If Not IsEmpty(deger.Value) And Left(UCase(Replace(Replace(deger.Value, "ı", "I"), "i", "İ")), Len(bakilan)) = bakilan Then
    sayac = sayac + 1
    sonuc = deger.Value
If sayac = 1 Then UserForm1.ListBox1.Clear
    UserForm1.ListBox1.AddItem deger.Value
End If
Next

'------------------------------------------------------------------------------------------------------
If sayac > 1 Then
    UserForm1.Tag = derlenen
    UserForm1.Caption = "Bir'den Fazla Uygun Kayıt Mevcut.. Birini Seçiniz.!"
    UserForm1.ListBox1.Tag = "off"
    UserForm1.Show
    UserForm1.ListBox1.Tag = ""
ElseIf sayac = 1 Then
    UserForm1.ListBox1.Tag = "off"
    Range(derlenen) = sonuc
Else
    UserForm1.ListBox1.Tag = "off"
    bakilan = ""
    sayac = 0
For Each deger In Sheets("RepertuvaR").Range("C2:C5000")
If Not IsEmpty(deger.Value) And Left(UCase(Replace(Replace(deger.Value, "ı", "I"), "i", "İ")), Len(bakilan)) = bakilan Then
    sayac = sayac + 1
    sonuc = deger.Value
If sayac = 1 Then UserForm1.ListBox1.Clear
    UserForm1.ListBox1.AddItem deger.Value
End If
Next
    UserForm1.Tag = derlenen
    UserForm1.Caption = "Uygun Kayıt Bulunamadı.. Listeden Birini Seciniz.!"
    'Range(derlenen) = ""
    UserForm1.Show
End If
'------------------------------------------------------------------------------------------------------
Else
    UserForm1.ListBox1.Tag = ""
End If
'******************************************************************************************************

'Yeni eklenen kodlar.. 13.02.2018  saat 11:19
If Target.Column = 3 Then
If Target.Value <> "" Then
Dim bul As Range
Set bul = Sayfa2.Range("C:C").Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not bul Is Nothing Then
For j = 4 To 9
    Cells(Target.Row, j) = Worksheets("RepertuvaR").Cells(satirno1 + 2, j)
Next
End If
End If
End If
        
Set bul = Nothing
atlason1:

'Yeni eklenen kodlar SONU ... 'sıra numarası..
On Error Resume Next
If Intersect(Target, Range("C17:C5000")) Is Nothing Then Exit Sub
If Target <> "" Then
    Cells(Target.Row, "A") = WorksheetFunction.Max(Range("A17:A" & Target.Row - 1)) + 1
Else
    Cells(Target.Row, "A") = ""
End If
    
End If
'///////////////////////////////////////////////////////////////////////////////////////////////////////

'Diger kodlar Otomatik Dönüstürme/Düzenleme vs...
Dim Alan As Range, Veri As Range, X As Long, Say As Variant, Metin As String
On Error GoTo Son
    
Application.EnableEvents = False
    
If Target.Cells.Count = 1 Then
    Set Alan = Target
Else
    Set Alan = Selection.Cells
End If
    
For Each Veri In Alan
Select Case Veri.Column
'-----------------------------------

Case 3, 4 'C ve D sütunlarina yazilani yazim düzenine döndürür..
    Veri.Value = WorksheetFunction.Proper(Veri.Value)
  
Range(Target.Address).Replace What:=";", Replacement:="; ", LookAt:=xlPart
Range(Target.Address).Replace What:=".", Replacement:=". ", LookAt:=xlPart
Range(Target.Address).Replace What:=",", Replacement:=", ", LookAt:=xlPart
Veri.Value = Trim(Veri.Value)

Range(Target.Address).Replace What:=";  ", Replacement:="; ", LookAt:=xlPart
Range(Target.Address).Replace What:=".  ", Replacement:=". ", LookAt:=xlPart
Range(Target.Address).Replace What:=",  ", Replacement:=", ", LookAt:=xlPart
Veri.Value = Trim(Veri.Value)
'-----------------------------------

Case 5 'E sütununda yazilan (Xxxx/XXXX) adresi, Yazim.Düzeni/BÜYÜKHARF'e döndürür..
If InStr(1, Veri.Value, "/") > 0 Then
    Say = Split(Veri.Value, "/")
For X = 0 To UBound(Say)
If X <> UBound(Say) Then
If Metin = "" Then
    Metin = WorksheetFunction.Proper(Say(X))
Else
    Metin = Metin & "/" & WorksheetFunction.Proper(Say(X))
End If
Else
    Metin = Metin & "/" & UCase(Replace(Replace(Say(X), "i", "I"), "i", "I"))
End If
Next
End If
    Veri.Value = IIf(Metin = "", WorksheetFunction.Proper(Veri.Value), Metin)
    Metin = ""
'-----------------------------------

Case 6, 8 'F ve H sütununda yazilani BÜYÜKHARF'e döndürür..
    Veri.Value = UCase(Replace(Replace(Veri.Value, "i", "I"), "i", "I"))
End Select
Next
    
Son: Application.EnableEvents = True

End Sub
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Çok saygıdeğer Korhan hocam..! Elinize ve bilginize sağlık, çok harika olmuş.. Son olarak şöyle bir şey düşündüm.. Bu dosyanın yanında "Arşiv" isimli bir Excel dosyası barındırıp, buradaki "girdi" sayfasını "Arşiv" dosyasına, sayfa olarak (günün tarihi adı ile) kopyalamak/yedeklemek mümkün olur mu? Maksat, yıllık 80 sayfa kadar olabilecek çalışmaları (80 ayrı dosya yerine) tek dosyada tutabilmek..
Herşey için teşekkürler ve ömür boyu muvaffakiyetler dilerim..
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Kod:
Sub Yedekle()
    Dim K1 As Workbook, K2 As Workbook
    Dim Yol As String, Dosya As String
    Dim Sayfa_Kontrol As Worksheet
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set K1 = ThisWorkbook
    Yol = K1.Path & Application.PathSeparator
    Dosya = Yol & "Arşiv.xlsx"
    
    If Dir(Dosya) = "" Then
        K1.Sheets("girdi").Copy
        ActiveWorkbook.Sheets(1).Name = Date
        ActiveSheet.DrawingObjects.Delete
        ActiveWorkbook.SaveAs Dosya, 51
        ActiveWorkbook.Close
    Else
        Set K2 = Workbooks.Open(Dosya, False, False)
        On Error Resume Next
        Set Sayfa_Kontrol = K2.Sheets(CStr(Date))
        On Error GoTo 0
        If Sayfa_Kontrol Is Nothing Then
            K1.Sheets("girdi").Copy After:=K2.Sheets(K2.Sheets.Count)
            K2.Sheets(K2.Sheets.Count).Name = Date
            K2.Sheets(K2.Sheets.Count).DrawingObjects.Delete
            K2.Close 1
        Else
            K1.Sheets("girdi").Copy After:=K2.Sheets(K2.Sheets.Count)
            Sayfa_Kontrol.Delete
            K2.Sheets(K2.Sheets.Count).Name = Date
            K2.Sheets(K2.Sheets.Count).DrawingObjects.Delete
            K2.Close 1
        End If
    End If

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    MsgBox "Yedekleme işlemi tamamlanmıştır.", vbInformation
End Sub
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Korhan hocam, çok harika olmuş, elleriniz dert görmesin..
1- Sayfayı "girdi-16.07.2019" şeklinde kaydediyor.. Sadece "16.07.2019" şeklinde kaydetse daha iyi olacak..
2- Bir de sayfadaki butonları da aktarıyor, butonları bir şekilde yok edebilsek, daha iyi olacak..
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Üstteki mesajımdaki kodu revize ettim. Deneyiniz.
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Değerli hocam, her şey için çok çok teşekkür ediyorum, her yardımınız harika oldu.. Sizleri daha fazla meşgul etmeyeyim derken, bir pürüz fark ettim.. "girdi" sayfası "C" sütunundan harf/kelime yazıp (enter diyerek veya userform'dan seçerek) veri çağırırken (otm. tamamlama), hizalarında ki (D-E-F-G-H-I sütunlarında) verileri getirmiyor, en üst satırın verilerini getiriyor.. (5 nolu mesajdaki kodları çalıştırırken..)
 
Son düzenleme:

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Korhan hocam, 10 nolu son talebin olabilirlik tarafı var mı?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kullandığınız kod bana gereksiz uzun geldi. Daha da kısalabilir gibi görünüyor.

İşlem adımlarını tarif ederseniz daha okunaklı kod yazabiliriz.
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Korhan hocam, söz konusu kod "otomatik tamamlama" dediğimiz hazır kelime/cümle kalıplarını (yazma gereği duymadan) başka sayfadan çağırma ihtiyacından doğdu.. Fakat kod'a daha sonra ihtiyaca göre ilaveler yaptım. Dosyanın son şeklini aşağıya ekledim ve kod'un yerine getirmesi istenilen görevleri de dosya içinde maddeler halinde yazdım.. (Bu Ptt gönderim listesi, haftada en az 2 kez yapıldığı ve bu kod'larla çok kolaylık sağlayacak)
 

Ekli dosyalar

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Korhan hocam, dediğiniz şekilde işlem adımlarını yukarıdaki dosyada (6 Madde halinde) tarif etmeye çalıştım. (olumsuzluk 1 maddede)
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Değerli hocam, herhalde iş yoğunluğundan bakamamışsınız, ben de sizi fazla meşgul ettim.. Her neyse bu kadarla yetinirim.. Her şey için tekrar tekrar teşekkürler dileğiyle hoşça kalınız.. Allh razı olsun..!
 

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,265
Excel Vers. ve Dili
Excel-2016
Teşekkürler hocam, sağlık ve afiyetle kalın..
 
Üst