• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Yazdırırken Sayfa Sayısına Göre Soru Numaralandırma

  • Konbuyu başlatan Konbuyu başlatan BedriA
  • Başlangıç tarihi Başlangıç tarihi
B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Arkadaşlar,

Evvela; barış içinde yaşamak dileğiyle
hepinizin bayramını kutluyorum.

Ekte örnek dosya var.

Sorunum şu: Makrolarla sınav kağıdı oluşturuyorum.
Bazı sorular uzun, bazıları ise kısa oluyor. Sorunun boyutuna
göre hücrenin esnemesini sağlamak, aşağıdaki kod ile mümkün...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Target.EntireRow.AutoFit
End Sub

Ancak hangi soru,
hangi hücreye gidecek kestirilemediği için, soru numaraları ayarlanamıyor.
Şöyle ki: Başlangıçta sabit satır ve sütun genişlikleri var ve soru numaraları
bu boyutlara göre atanmış. Soru esneyince bir alt sayfaya geçebiliyor.
Böyle olunca aynı sayfadaki soruların numaraları ardışık olmuyor.
Örnek dosyada baskı önizleme yaparsanız, anlatmak istediğim somutlaşacaktır.

Dosyayı buradan da indirebilirsiniz.

Sayfa sayısı soruların boyutuna göre değişecek; ama diyelim ki 10 soru 3 sayfaya dağıldı, o zaman her sayfadaki soruların numaraları ardışık olsun.

Bunun için nasıl bir çözüm bulabiliriz acaba?
 

Ekli dosyalar

Son düzenleme:
Hocam çok teşekkürler.
Yalnız ben numaraların yanına nokta koyuyorum.
Verdiğiniz koda ekledim ama iki nokta yan yana koyuyor.
Kırmızı kısımlardan hangisini düzeltmem gerekiyor?

Hocam 20 soruluk bir kağıtta denedim, sarı kısımda hata verdi.
Sanırım üç sayfaya kadar işlem yapıyor, 4. sayfanın numaralarına karışmıyor.
Ben de 50 soruluk kağıt da var, en az 10 sayfalık...
Tüm kağıtlarda format aynı, aşağı doğru artıyor sadece soru sayısı arttıkça.

Kod: 
Sub numara_ver()
Dim a As Long, b As Long, c As Long, d As Long
Dim e As Integer
Dim f As Range
Dim s1 As Worksheet
 Set s1 = ActiveSheet
 a = s1.HPageBreaks.Count
 b = 8
 d = s1.HPageBreaks(1).Location.Offset(-1, 0).Row
 e = 0
's1.[D:D].NumberFormat = "@"
's1.[F:F].NumberFormat = "@"
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
[COLOR="red"] f.Value = e & "." & Chr(46)[/COLOR]
 Next
 For c = 1 To a - 1
 b = s1.HPageBreaks(c).Location.Offset(0).Row
 d = s1.HPageBreaks(c + 1).Location.Offset(-1, 0).Row
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
[COLOR="Red"] f.Value = e & "." & Chr(46)[/COLOR]
 Next
 Next
 b = s1.HPageBreaks(a).Location.Offset(0).Row
[COLOR="DarkOrange"]d = s1.[E:G].Find("A)", , xlValues, xlPart, xlByRows, xlPrevious, False).Row[/COLOR]
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
[COLOR="red"] f.Value = e & "." & Chr(46)[/COLOR]
 Next

End Sub
 
Son düzenleme:
BedriA' Alıntı:
Verdiğiniz koda ekledim ama iki nokta yan yana koyuyor.
Kırmızı kısımlardan hangisini düzeltmem gerekiyor?
Genişletmek için tıkla ...
Merhaba
46 noktanın ascıı kodu (chr(46)) olduğundan birini silmeniz yeterli. Aşağıdaki kodlarda sizin yaptığınız gibi yapalım.
BedriA' Alıntı:

20 soruluk bir kağıtta denedim, sarı kısımda hata verdi.
Sanırım üç sayfaya kadar işlem yapıyor, 4. sayfanın numaralarına karışmıyor.
Ben de 50 soruluk kağıt da var, en az 10 sayfalık...
Tüm kağıtlarda format aynı, aşağı doğru artıyor sadece soru sayısı arttıkça.
Genişletmek için tıkla ...
Örnek dosyanızda; sayfadaki düzeni görünce, verileri ekleyen kodlarınızda
yazdırma alanı belirleyen bölüm vardır diye düşünmüştüm.
Kodları aşağıdaki gibi denermisiniz?

Ek örnek dosya

Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim a As Long, b As Long, c As Long, d As Long
Dim e As Integer
Dim f As Range
Dim s1 As Worksheet
 Set s1 = ActiveSheet
 s1.PageSetup.PrintArea = "$D$1:$G$" _
 & s1.[E:G].Find("*", , xlValues, xlPart, xlByRows, xlPrevious, False).Row
 Application.ScreenUpdating = False
  ActiveWindow.View = xlPageBreakPreview
 a = s1.HPageBreaks.Count
 b = 8
 d = s1.HPageBreaks(1).Location.Offset(-1, 0).Row
 e = 0
[COLOR="Red"]s1.[D:D].NumberFormat = "@"
s1.[F:F].NumberFormat = "@"[/COLOR]

 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 f.Value = e & "."
 Next
 For c = 1 To a - 1
 b = s1.HPageBreaks(c).Location.Offset(0).Row
 d = s1.HPageBreaks(c + 1).Location.Offset(-1, 0).Row
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 f.Value = e & "."
 Next
 Next
 b = s1.HPageBreaks(a).Location.Offset(0).Row
[COLOR="Blue"]d = s1.Cells(Rows.Count, "F").End(3).Row - 3[/COLOR]
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 If Trim(s1.Cells(f.Row, f.Column + 1)) <> "" Then f.Value = e & "."
 Next
ActiveWindow.View = xlNormalView
    Application.ScreenUpdating = True
End Sub [/SIZE]
 
Son düzenleme:
BedriA' Alıntı:
Hocam ekteki dosyaları inceler misiniz?
Sonlara doğru sıralama bozuluyor.
Genişletmek için tıkla ...
Merhaba
Kodlarımızın son bölümünde
Kod: 
[SIZE="2"] 
'....
'...
b = s1.HPageBreaks(a).Location.Offset(0).Row
[COLOR="Blue"]d = s1.[E:G].Find([COLOR="Red"]"A)"[/COLOR], , xlValues, xlPart, xlByRows, xlPrevious, False).Row[/COLOR]
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 If Trim(s1.Cells(f.Row, f.Column + 1)) <> "" Then f.Value = e & "."
 Next
ActiveWindow.View = xlNormalView
    Application.ScreenUpdating = True
End Sub [/SIZE]

En son sorunun hangi hücrede olduğunu bulmak için yukarıdaki kırmızı bölüm bulunuyor "A)" şıkkını arıyor örneğinizde (PDF lerde) sorular var ama şıklar yok
onun içinde son işlem yapılacak satırı bulamamış.
Bunun yerine örnek dosyanıza göre; son satırdan 3 eksik son soru satırıdır
sabit ise aşağıdaki gibide olabilir.

Kod: 
 d= s1.cells(rows.count,"F").end(3).row-3
 
Hocam sınavlar her zaman çoktan seçmeli olmuyor.
Bazen de klasik oluyor.

O yüzden bu yol hataya neden olacak.
Son soru sabit, hep son satırdan 3 önce oluyor.
Ama soru sayısının tek veya çift olmasına göre bulunduğu sütun değişiyor.

Kodun son halini paylaşabilir misiniz? Sabit olacak şekliyle...
Ben değiştirince hata aldım.
 
PLİNT' Alıntı:
Kodları yukarıdaki (4.Mesajda) değişen şekliyle deneyebilirsiniz değişen bölüm
Genişletmek için tıkla ...

Çok teşekkürler hocam.

Aşağıdaki şekilde tam istediğim gibi çalışıyor.

Kod: 
Sub numara_ver()
Dim a As Long, b As Long, c As Long, d As Long
Dim e As Integer
Dim f As Range
Dim s1 As Worksheet
 Set s1 = ActiveSheet
 s1.PageSetup.PrintArea = "$D$1:$G$" _
 & s1.[E:G].Find("*", , xlValues, xlPart, xlByRows, xlPrevious, False).Row
 Application.ScreenUpdating = False
  ActiveWindow.View = xlPageBreakPreview
 a = s1.HPageBreaks.Count
 b = 8
 d = s1.HPageBreaks(1).Location.Offset(-1, 0).Row
 e = 0
's1.[D:D].NumberFormat = "@"
's1.[F:F].NumberFormat = "@"

 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 f.Value = e & "."
 Next
 For c = 1 To a - 1
 b = s1.HPageBreaks(c).Location.Offset(0).Row
 d = s1.HPageBreaks(c + 1).Location.Offset(-1, 0).Row
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 f.Value = e & "."
 Next
 Next
 b = s1.HPageBreaks(a).Location.Offset(0).Row
 On Error Resume Next
d = s1.Cells(Rows.Count, "F").End(3).Row - 3
 For Each f In s1.Range("D" & b & ":D" & d & "," & "F" & b & ":F" & d)
 e = e + 1
 If Trim(s1.Cells(f.Row, f.Column + 1)) <> "" Then f.Value = e & "."
 Next
ActiveWindow.View = xlNormalView
    Application.ScreenUpdating = True

End Sub
 
PLİNT' Alıntı:
Rica ederim.
Kolay gelsin, hayırlı geceler
Genişletmek için tıkla ...


Hocam sizden son bir şey rica edeyim:
Label içindeki metin kaydetmeden önce,
metnin sonunda bir boş satırı nasıl ekleyebilirim?

Kağıtta bitişik görüyor yok.
 
Son düzenleme:
BedriA' Alıntı:
Hocam sizden son bir şey rica edeyim:
Label içindeki metin kaydetmeden önce,
metnin sonunda bir boş satırı nasıl ekleyebilirim?

Kağıtta bitişik görüyor yok.
Genişletmek için tıkla ...
Hücreye kayıt yaparken
Range("a1") = label1.caption & Chr(10)
veya
= label1.caption & vbcrlf
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst