Bir Alanı Şablon Olarak Kullanma

[Eser Gökay]

Birkaç gün önce yazmış olduğum bir soruya yeterli cevabı alamadığım için yeniden ve biraz daha farklı anlatarak yeniden sorma ihtiyacı hissettim. Ayrıntı ektedir. İlgilerinizi rica ediyorum. İyi çalışmalar.

 

[Eser Gökay]

Arkadaşlar bu konuda fikri olan var mı acaba ?

 

[Levent Menteşoğlu]

Aşağıdaki kodu denermisiniz.

Sub sablonekle()
Application.ScreenUpdating = False
sor = InputBox("Şablon Ekleme Sayısını giriniz.", "ŞABLON EKLEME")
If sor = "" Then Exit Sub
[1:65536].EntireRow.Hidden = False
For a = 1 To sor
say = WorksheetFunction.CountA([b:b])
satir = say * 8 + 3
Sheets("sablon").[a1:o8].Copy Cells(satir, "c")
Cells(satir, "b") = say + 1
Next
[a:b].Interior.ColorIndex = xlNone
Rows(satir + 8).Interior.ColorIndex = 15
Rows(satir + 9 & ":65536").EntireRow.Hidden = True
End Sub

 

[Eser Gökay]

Levent Hocam çok teşekkür ediyorum. Elinize sağlık yine dehşet bir iş çıkarmışsınız.

 

[Levent Menteşoğlu]

Rica ederim Eser bey. Ben sadece manuel olarak yapacağınız işlem sırasını peşpeşe dizdim o kadar.

 

[Eser Gökay]

Üstadım kendi dosyama uyarlarken sıkıntı yaşadım. Lütfen hatamın yerini de söylerseniz bu tip bir kaç çalışmam olacak. teşekkür ediyorum. Ayrıca ekleme yaparken sormasa daha iyi olacak.

 

[Korhan Ayhan]

Selamlar,

Levent beyin önerdiği kodu aşağıdaki şekilde düzenleyip denermisiniz.

Option Explicit
 
Sub ŞABLON_EKLE()
    Dim SOR As Variant, X As Long, SAY As Long, SATIR As Long
    Application.ScreenUpdating = False
    SOR = InputBox("Şablon Ekleme Sayısını giriniz.", "ŞABLON EKLEME")
    If SOR = "" Then Exit Sub
    [5:65536].EntireRow.Hidden = False
    For X = 1 To SOR
    SAY = WorksheetFunction.CountA([A5:A65536])
    SATIR = IIf([B65536].End(3).Row = 3, [B65536].End(3).Row + 2, [B65536].End(3).Row + 1)
    Sheets("PRT").[A1:T50].Copy Cells(SATIR, "A")
    Cells(SATIR + 20, "A") = SAY + 1
    Next
    [A5:B65536].Interior.ColorIndex = xlNone
    Rows(SATIR + 50).Interior.ColorIndex = 15
    Rows(SATIR + 51 & ":65536").EntireRow.Hidden = True
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Eser Gökay]

Levent ve Korhan Beylere çok teşekkür ediyorum. İyi çalışmalar