Belirli hücre aralığına girilen değeri yazdırma

[owertake]

Herkese Merhaba.
Değerli arkadaşlarım, yapmak istediğim işlem şu şekilde;
Kullandığım excelde başlangıç a4 bitiş a5000, a4 ten a156 ya kadar olan kısıma 1, a158 den a310 olan kısıma 2, a312 den a464 e kadar 3 .... gibi a5000 e kadar girdiğim değerleri yazdırmak istiyorum. Her 152 hücrede 1 boşluk var. 152 hücreye bir değer sonra 1 boşluk sonraki 152 hücreye diğer değer şeklinde bir sistem yapmak istiyorum.
Sistemde basit bir şekilde 2 textbox ve 1 buton şeklinde. 1. textbox hücre başlangıç değeri (1) yani ilk 152 hücreye yazdıracak, 2. textbox da bitiş değeri 25. Butona tıkladığımda ilk 152 hücreye 1, bir hücre atlayacak, sonra tekrar 152 hücreye 2, yine bir hücre atlayacak, yine 152 hücreye 3 şeklinde 2. textbox'a girdiğim değere kadar devam edecek. Böyle bir sistem yapılabilir mi? Yardımcı olursanız çok sevinirim.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodu deneyin, eğer olmazsa örnek dosyanızı ekleyin üzerinde yapalım.
Örnek dosyanızı dosya.tc gibi bir paylaşım sitesine ekleyebilirsiniz.

Private Sub CommandButton1_Click()
    Dim Bak As Integer
    Dim SiraNo As Integer
    
    If Not IsNumeric(TextBox1.Text) Or Not IsNumeric(TextBox2.Text) Then
        MsgBox "Lütfen TextBox1 ve TextBox2 ye bir rakam giriniz.", vbExclamation
        Exit Sub
    End If
    
    For Bak = TextBox1.Text To TextBox2.Text * 153 Step 153
        SiraNo = SiraNo + 1
        Cells(Bak, "A").Resize(152, 1).Value = SiraNo
    Next
End Sub

 

[owertake]

Hocam elinize sağlık. Fakat 2. textboxa girdiğim değere kadar değıilde 10 a kadar gidiyor. Sonrasında 15 değerini textbox 1 e girdiğimde a10 dan başlıyor. yani 1. textboxa 1 textbox2 de 6 girdim diyelim. son değeri yazdırdıktan sonra yeni değer girdiğimde son değerin altına yazdırarak devam edecek. Sayfa bittikten sonra tüm sütunu silip yeni değerler girdiğimde yine a1 den başlayıp devam edecek şekilde çalışması gerekiyor.

Örnek Dosya : https://os5.mycloud.com/action/share/12170aa1-c335-4c54-82fb-816e33b1549a

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Private Sub CommandButton1_Click()
    Dim No As Long, X As Long
    
    If Not IsNumeric(TextBox1) Or Not IsNumeric(TextBox2) Then
        MsgBox "Lütfen sayı girişi yapınız!", vbCritical
        Exit Sub
    End If
    
    No = IIf(Range("A5") = "", 5, Cells(Rows.Count, 1).End(3).Row + 2)
    
    For X = TextBox1 To TextBox2
        If WorksheetFunction.CountIf(Range("A:A"), X) = 0 Then
            Range("A" & No).Resize(152) = X
            No = No + 153
        End If
    Next

    If Cells(Rows.Count, 1).End(3).Row > 5000 Then
        If MsgBox("Sayfa doldu!" & vbCrLf & "Veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub
        Range("A:A").ClearContents
        Call UserForm_Initialize
        MsgBox "Veriler silinmiştir.", vbInformation
    Else
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    End If
End Sub

Private Sub UserForm_Initialize()
    TextBox1 = WorksheetFunction.Max(Range("A:A")) + 1
    TextBox2 = Empty
    TextBox2.SetFocus
End Sub

 

[owertake]

Korhan Hocam elinize sağlık istediğim gibi olmuş tek eksiğim var o da her 152. hücreden sonra 1 hücre boşluk atayıp devam etmesi gerekiyor. Eğer onuda ekleyebilirsem mükemmel olacak. Çok teşekkür ediyorum desteğiniz için.

 

[Korhan Ayhan]

Kodu revize ettim. Tekrar deneyiniz.

 

[owertake]

Korhan Hocam Aynı şekilde devam ediyor. Maalesef sırada kayma oluyor.
İlk satıra boşluk atıyor. Her 153. satır yine dolu şekilde devam ediyor.
Örnek dosyayı linkten kontrol edebilirsiniz.

My Cloud

Shared with My Cloud

os5.mycloud.com

 

[Muzaffer Ali]

Deneyiniz.

Private Sub CommandButton1_Click()
    Dim Bak As Integer
    Dim Say As Long
   
    If Not IsNumeric(TextBox1.Text) Or Not IsNumeric(TextBox2.Text) Then
        MsgBox "Lütfen TextBox1 ve TextBox2 ye rakam giriniz.", vbExclamation
        Exit Sub
    End If
   
    For Bak = TextBox1.Text To TextBox2.Text
        Say = Cells(Rows.Count, "A").End(xlUp).Row
        If IsNumeric(Cells(Say, "A")) Then Say = Say + 1
        Cells(Say + 1, "A").Resize(152, 1).Value = Bak
    Next
End Sub

 

[owertake]

Hocam elleriniz dert görmesin. Şuan istediğim gibi çalışıyor çok teşekkür ederim.

 

[Korhan Ayhan]

İlk mesajınızda verdiğiniz hücre adreslerini sayınca 153 hücre yapıyordu. Bende kodu ona göre kurguladım. Ayrıca A4 hücresinden başlayacak demişsiniz. Fakat eklediğiniz dosyada A4 hücresinde başlık var. Durum böyle olunca önerdiğimiz kod eksik çalışıyor gibi görünüyor.

Önerdiğim kodu örnek dosyanıza göre revize ettim. Tekrar deneyiniz.

 

[owertake]

Yazım hatası olmuş hocam kusura bakmayın. Tam istediğim gibi olmuş ellerinize sağlık.

 

[owertake]

İlk mesajınızda verdiğiniz hücre adreslerini sayınca 153 hücre yapıyordu. Bende kodu ona göre kurguladım. Ayrıca A4 hücresinden başlayacak demişsiniz. Fakat eklediğiniz dosyada A4 hücresinde başlık var. Durum böyle olunca önerdiğimiz kod eksik çalışıyor gibi görünüyor.

Önerdiğim kodu örnek dosyanıza göre revize ettim. Tekrar deneyiniz.

Sayın Muzaffer Hocam ve Korhan Hocam, aynı kod üzerinden değişiklik yapmak istiyorum. Textboxları artırıp aralıktaki boşluk değerlerini kaldırmak istiyorum. Örnek olarak 1 den 7 ye kadar devam eden sayı 12 ye atlıyor. Ben bu kodu 1 den 7 ye sonrasında 12 den 23 e sonrasında 26 dan 32 ye gibi textboxlara değer girerek yapabilir miyim? Kodlar üzerinde denedim fakat olmadı.

Option Explicit

Private Sub CommandButton1_Click()
Dim No As Long, X As Long

If Not IsNumeric(TextBox1) Or Not IsNumeric(TextBox2) Then
MsgBox "Lütfen sayı girişi yapınız!", vbCritical
Exit Sub
End If

No = IIf(Range("A5") = "", 5, Cells(Rows.Count, 1).End(3).Row + 2)

For X = TextBox1 To TextBox2
If WorksheetFunction.CountIf(Range("A:A"), X) = 0 Then
Range("A" & No).Resize(152) = X
No = No + 153
End If
Next

If Cells(Rows.Count, 1).End(3).Row > 10000 Then
If MsgBox("Sayfa doldu!" & vbCrLf & "Veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub
Range("A:A").ClearContents
Call UserForm_Initialize
MsgBox "Veriler silinmiştir.", vbInformation
Else
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End If
End Sub

TextBox1 = WorksheetFunction.Max(Range("A:A")) + 1
TextBox2 = Empty
TextBox2.SetFocus
End Sub


Dim No1 As Long, X1 As Long

If Not IsNumeric(TextBox3) Or Not IsNumeric(TextBox4) Then
MsgBox "Lütfen sayı girişi yapınız!", vbCritical
Exit Sub
End If

No1 = IIf(Range("A5") = "", 5, Cells(Rows.Count, 1).End(3).Row + 2)

For X1 = TextBox3 To TextBox4
If WorksheetFunction.CountIf(Range("A:A"), X1) = 0 Then
Range("A" & No1).Resize(152) = X1
No1 = No1 + 153
End If
Next

If Cells(Rows.Count, 1).End(3).Row > 10000 Then
If MsgBox("Sayfa doldu!" & vbCrLf & "Veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub
Range("A:A").ClearContents
Call UserForm_Initialize
MsgBox "Veriler silinmiştir.", vbInformation
Else
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End If
End Sub

TextBox3 = WorksheetFunction.Max(Range("A:A")) + 1
TextBox4 = Empty
TextBox4.SetFocus
End Sub

Dim No2 As Long, X2 As Long

If Not IsNumeric(TextBox5) Or Not IsNumeric(TextBox6) Then
MsgBox "Lütfen sayı girişi yapınız!", vbCritical
Exit Sub
End If

No2 = IIf(Range("A5") = "", 5, Cells(Rows.Count, 1).End(3).Row + 2)

For X2 = TextBox5 To TextBox6
If WorksheetFunction.CountIf(Range("A:A"), X2) = 0 Then
Range("A" & No2).Resize(152) = X2
No2 = No2 + 153
End If
Next

If Cells(Rows.Count, 1).End(3).Row > 10000 Then
If MsgBox("Sayfa doldu!" & vbCrLf & "Veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub
Range("A:A").ClearContents
Call UserForm_Initialize
MsgBox "Veriler silinmiştir.", vbInformation
Else
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End If
End Sub

TextBox5 = WorksheetFunction.Max(Range("A:A")) + 1
TextBox6 = Empty
TextBox6.SetFocus
End Sub


Private Sub UserForm_Click()

End Sub

 

[Muzaffer Ali]

Yazdığım kodlar tam sizin istediğiniz gibi çalışıyor.