Soru Seri numara yazdırma yardım

[Bigtoss]

Herkese merhabalar
Seri numarası yazdırma ile alakalı çok araştırdım fakat benim istediğim gibi birşey bulamadım bu yüzden yardımlarınızı bekliyorum. Ekli dosyada açıklama olarakta ne istediğimi yazdım şimdiden yardımlarınız için teşekkür ederim.

 

[Bigtoss]

Yanlış dosyayı yüklemişim doğru olan dosya bu

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Private Sub CommandButton1_Click()
Dim bas As Integer, son As Integer, a As Integer
Dim sat As Byte, sut As Byte
bas = CInt(TextBox1)
son = CInt(TextBox1) + CInt(TextBox2) - 1
sat = 1
sut = 1
Sayfa1.UsedRange.ClearContents
For a = bas To son
    Sayfa1.Cells(sat, sut) = a
    If sat = 40 Then
        sat = 1
        sut = sut + 2
    Else
        sat = sat + 1
    End If
Next
End Sub

Private Sub CommandButton2_Click()
Unload Me
Sayfa1.PrintPreview
End Sub

 

[Bigtoss]

Ömer bey çok teşekkür ederim kod tam istediğim gibi çalışıyor emeğinize sağlık.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...

 

[Asri]

Alternatif;
İlk sayfayı şablon olarak kullanır.

Sub basla()
   ilksayi = Sheets("Menu").Range("L10").Value
   adet = Sheets("Menu").Range("L11").Value
   Sheets("Seriler").Select
   Cells.ClearContents
 
   satir = 1
   sutun = 1
 
   For i = 1 To adet
      Cells(satir, sutun).Value = ilksayi
      satir = satir + 1
      ilksayi = ilksayi + 1
      If satir = 41 Then
         satir = 1
       
         If sutun Mod 13 = 0 Then
             Columns("A:M").Select
             Selection.Copy
             Columns(sutun + 1).Resize(, 13).Select
             Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
             Application.CutCopyMode = False
             Range("R5").Select
             sutun = sutun + 1
        Else
             sutun = sutun + 2
        End If
       
      End If
   Next i
End Sub

 

[Korhan Ayhan]

Altenatif;

Hız olarak avantaj sağlayacaktır.

Option Explicit

Private Sub CommandButton1_Click()
    Dim Zaman As Double, X As Long, Satir As Long
    Dim Sutun As Integer, Katsayi As Integer
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Cells.ClearContents
    
    Satir = 1
    Sutun = 1
    Katsayi = 40
    
    For X = TextBox1 To TextBox2 Step Katsayi
        If (X + Katsayi) > Val(TextBox2) Then
            Katsayi = Val(TextBox2) - X + 1
        End If
        
        Cells(Satir, Sutun) = X
        Cells(Satir, Sutun).AutoFill Destination:=Cells(Satir, Sutun).Resize(Katsayi), Type:=xlFillSeries
        Sutun = Sutun + 2
        If Sutun Mod 15 = 0 Then
            Satir = Satir + 40
            Sutun = 1
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "Seri numaraları sayfaya aktarılmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Private Sub CommandButton2_Click()
    Unload Me
    Sheets("Sayfa1").PrintPreview
End Sub