uzun excel dosyasında sayfa sonu

[ada002]

Merhaba,

Uzun bir excel dosyam var ve ben bunun belirli kelimesine geldiğinde sayfa atlamasını istiyorum.Elle yapmak çok uuzun sürüyor.Bir makro yada formül varmıdır?.Nakli Yekün'den sonra bir sonraki sayfayı otomatik sayfa başı yapmasını istiyorum.yardımcı olursanız çok sevinirim?

 

[Ömer]

Merhaba,

Sorunuz net değil. Küçük bir örnek dosya ekleyerek dosya içerisinde gerekli açıklamaları yapmanızı rica ederim.

 

[ada002]

profilime dosyayı ekledim ama buraya nasıl ekleyeceğimi bilmiyorum

 

[ada002]

[

Ekli dosyayı görüntüle YEVMİYE-2.xlsx

 

[Ömer]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayın. J sütununda herhangi bir hücreye çift tıklarsanız tıklanan hücreden aşağıya doğru "nakli yekün" satırını arayarak bulduğu hücreye gider.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
    Dim c As Range
    
    If Intersect(Target, Range("J:J")) Is Nothing Then Exit Sub
    Set c = Range("J" & Target.Row + 1 & ":J" & Rows.Count).Find("NAKLİ YEKÜN")
    If Not c Is Nothing Then c.Select
 
End Sub

.

 

[ada002]

Merhaba,
Sanırım yanlış anlattım.Ben çıktı alırken her nakli yekün gördüğünde sayfa sonu yapmasını istiyorum.Bu mümkün olurmu?

 

[ada002]

bu konuda bana yardımcı olabilecek kimse varmı

 

[Ömer]

Bu şekilde deneyin.

Sub Yazdir()
    
    Dim son As Long, a As Long, b As Long, i As Long, c As Range, j As Byte
    
    son = Cells(Rows.Count, "J").End(xlUp).Row
    
    a = 1
    For i = 1 To son
        Set c = Range("J" & a + 5 & ":J" & Rows.Count).Find("NAKLİ YEKÜN")
        If Not c Is Nothing Or son - a < 5 Then
            With ActiveSheet.PageSetup
                b = son - a + 1: j = 0
                If son - a >= 5 Then b = c.Row - a + 1: j = 1
                If son - a < 5 Then b = son - a + 1
                .PrintArea = Cells(a, "A").Resize(b, 12).Address()
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            [COLOR="red"]ActiveSheet.PrintOut[/COLOR]
            Application.Wait Now + TimeValue("00:00:01")
            If son - a >= 5 Then a = c.Row + 1
            If j = 0 Then Exit For
        End If
    Next i
    
End Sub

ActiveSheet.PrintOut

yerine, aşağıdaki satırı yazarsanız yazdırmadan önce ön izleme yapabilirsiniz.

ActiveSheet.PrintPreview

.

 

[aacanakova]

''Nakli Yekün'' yerine 1001-1002 -1003 -1004 diye 1650 ye kadar giden bir liste var .

1001 bittiği zaman sayfa sonu yapacak .
1002 bittiği zaman sayfa sonu yapacak
1003 bittiği zaman sayfa sonu yapacak . Bu şekilde 1650 ye kadar olan listeyi bir seferde yazdırabilirmiyim .

 

[aacanakova]

Arkadaşlar cevap verebilecek kimse var mı acaba . Önemli benim için gün içerisinde mutlaka çıktıları almam lazım . Tek tek yapacağım yoksa

 

[aacanakova]

arkadaşlar rica etsem bir cevap .

 

[Ömer]

Tablo yapınızı bilmeden kod yazmak zor. Dosyanıza uygun küçük bir örneği eklemenizi rica ederim.

 

[aacanakova]

Şu şekilde bir dosya . YAZDIR DEDİĞİMDE ÖNCE 1001 LERİN OLDUĞU SAYFALARI YAZACAK . 1001 LER BİTİNCE SAYFA SONU YAPIP 1002 YE GEÇECEK

Mahalle No Sira TCKimlikNo Ad Soyad Dogum Tarihi Adres
A.GAZİ MAH. 1001 1 11111111111 ERCAN AKOVA 18/18/1975 ABANT SOKAK K:5 D:2
A.GAZİ MAH. 1001 2 11111111111 ERCAN AKOVA 18/18/1976 ABANT SOKAK K:5 D:3
A.GAZİ MAH. 1002 3 11111111111 ERCAN AKOVA 18/18/1977 ABANT SOKAK K:5 D:4

 

[Ömer]

Bu şekilde deneyin.

Sub Yazdir()
    
    Dim i As Long, c As Range, say As Long

    ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"

    For i = 1001 To 1650
        Set c = Range("B:B").Find(i, , xlValues, xlWhole)
        say = WorksheetFunction.CountIf([B:B], i)
        If Not c Is Nothing Then
            With ActiveSheet.PageSetup
                .PrintArea = Cells(c.Row, "A").Resize(say, 7).Address()
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            [COLOR="Red"]ActiveSheet.PrintOut[/COLOR]
            Application.Wait Now + TimeValue("00:00:01")
        End If
    Next i
    
    ActiveSheet.PageSetup.PrintArea = ""
    
End Sub

ActiveSheet.PrintOut

yerine, aşağıdaki satırı yazarsanız yazdırmadan önce ön izleme yapabilirsiniz.

ActiveSheet.PrintPreview

.

 

[aacanakova]

Ömer hocam yazdıramadım . Kodu kopyalayıp yapıştırdım kod sayfasına . Önizleme için ActiveSheet.PrintPreview ile değiştirdim ama hala eskisi gibi görünüyor . Yardımcı olurmusunuz .
Nasıl yazıcıya göndericem kodu yazıp

 

[Ömer]

Önce kodları silin. VBA ekranında iken ( Excel sayfasında iken ALT F11 ile geçebilirsiniz). Insert menüsünden Module ekleyin. Eklenen bu Module kodları yapıştırın. Daha sonra excel sayfasına dönerek Alt F8 ile yaptığınızda bir ekran açılır, "Yazdir" kodu seçili iken çalıştır butonuna basın.

 

[aacanakova]

Ömer Hocam hallettim tamam hata bende elinize sağlık .

 

[aacanakova]

Sub Yazdir()

Dim i As Long, c As Range, say As Long

ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"

For i = 1001 To 1650
Set c = Range("C:C").Find(i, , xlValues, xlWhole)
say = WorksheetFunction.CountIf([C:C], i)
If Not c Is Nothing Then
With ActiveSheet.PageSetup
.PrintArea = Cells(c.Row, "A").Resize(say, 11).Address()
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
ActiveSheet.PrintOut
Application.Wait Now + TimeValue("00:00:01")
End If
Next i

ActiveSheet.PageSetup.PrintArea = ""

End Sub





Bu kodu Ömer Hocam yazmıştı daha önce eline sağlık çok kullanışlı oldu .
Şimdi oluşturduğum özet tablı var . Aynı kodu aşağıdaki şekilde düzenlemek mümkün mü acaba .
Önce kaçtabe varsa 1001 dekileri yazdıracak 1002 ye kadar , sonra 1002 leri sonra 1003 leri gibi devam edecek

1001
BAYBURT 33
KARS 33
TRABZON 29
SİVAS 26
ORDU 21
ERZURUM 20
SİNOP 19
İSTANBUL 18
GÜMÜŞHANE 17
KASTAMONU 12
BİNGÖL 12
ERZİNCAN 11
ÇORUM 11
ARDAHAN 10
RİZE 10
AKSARAY 7
SAMSUN 6
SİİRT 3
BİTLİS 3
MALATYA 3
AĞRI 2
ARTVİN 2
BALIKESİR 2
KAYSERİ 1
TOKAT 1
IĞDIR 1
TEKİRDAĞ 1

1002
ERZİNCAN 11
ÇORUM 11
ARDAHAN 10
RİZE 10
AKSARAY 7
SAMSUN 6
SİİRT 3
BİTLİS 3
MALATYA 3
AĞRI 2
ARTVİN 2
BALIKESİR 2
KAYSERİ 1
TOKAT 1
IĞDIR 1
TEKİRDAĞ 1