Bilgi girilen sayfaya çerçeve koymak

[abdullah016]

Merhaba.
Bir sayfaya bilgi girdiğimde o sayfanın hücrelerine çerçeve koymak için çalışıyorum.fakat başarılı olamadım.
Bundaki amacım sayfaların tamamını çerçeveye alıp exceli yavaşlatmamak.
Dosyayı ekte gönderiyorum.yardımcı olursanız müteşekkir olacağım.

 

[programer]

CommandButton1 kodlarını aşağıdaki gibi değiştirin

Private Sub CommandButton1_Click()
Sheets("Faaliyet").Select
On Error Resume Next
If TextBox1.text = "" Then
Sheets("Faaliyet").Select
MsgBox ("Lütfen 'Tarih' Alanını Boş Bırakmayın..."), vbCritical, ("TARİH BÖLÜMÜ BOŞ")
TextBox1.SetFocus
Exit Sub
End If
Dim i As Integer
For i = 3 To 25515
If (ActiveSheet.Cells(i, 1) = "") Then
ActiveSheet.Cells(i, 1) = CLng(CDate(TextBox1))
ActiveSheet.Cells(i, 2) = ComboBox1.text
ActiveSheet.Cells(i, 3) = TextBox2.text
ActiveSheet.Cells(i, 4) = TextBox3.text
ActiveSheet.Cells(i, 5) = ComboBox2.text
ActiveSheet.Cells(i, 6) = ComboBox3.text
ActiveSheet.Cells(i, 7) = TextBox4.text
ActiveSheet.Cells(i, 8) = TextBox5.text
ActiveSheet.Cells(i, 9) = TextBox6.text
ActiveSheet.Cells(i, 10) = TextBox7.text
ActiveSheet.Cells(i, 11) = TextBox8.text
ActiveSheet.Cells(i, 12) = ComboBox4.text

MsgBox "Bilgi Eklendi !...", vbOKOnly + vbInformation, "Bilgi Ekleme"

For s = 2 To 8
Controls("textbox" & s) = ""
Next
For a = 1 To 4
Controls("combobox" & a) = ""
Next
MsgBox "YENİ KAYITLAR İÇİN VERİLER SİLİNMİŞTİR.", vbInformation
Range("A3:g65515").Sort Key1:=Range("a3"), Order1:=xlAscending
Sheets("Faaliyet").Select
ActiveWorkbook.Save
Exit Sub
End If
Next i

Dim yeni As String
sonsutun = "G"
Range("A1").Select
sayi = WorksheetFunction.CountA(Sheets("Faaliyet").Range("a1:a65000"))
yeni = sonsutun + Trim(Str$(Val(sayi)))
With Sheets("Faaliyet").Range("a1:" & yeni)
    .Borders.LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlHairline
    .Borders(xlEdgeLeft).LineStyle = xlHairline
    .Borders(xlEdgeRight).LineStyle = xlHairline
    .Borders(xlEdgeTop).LineStyle = xlHairline
    .Borders(xlInsideVertical).LineStyle = xlHairline
    .Borders(xlInsideHorizontal).LineStyle = xlHairline
End With

End Sub

 

[abdullah016]

sn.programer
verdiğiniz kodları denedim fakat başarılı olamadım.bir yerde hata yapıyorumdur mutlaka
beni daha açıklayıcı olarak yönlendirebilirmisiniz.
teşekkür ederim.

 

[programer]

örnek dosyanızın sayfa koruması olduğu için deneme şansım olmadı şifreyi verirseniz yada korumayı kaldırıp dosyanızı tekrar eklerseniz yardımcı olmaya çalışayım

 

[abdullah016]

özür dilerim unutmuşum.
dosyayı gönderiyorum.
teşekkür ederim.

 

[programer]

kodları aşağıdaki gibi değiştirirseniz istediğiniz gibi çalışacaktır.

Dim yeni As String

Private Sub CommandButton1_Click()
Sheets("Faaliyet").Select
On Error Resume Next
If TextBox1.text = "" Then
Sheets("Faaliyet").Select
MsgBox ("Lütfen 'Tarih' Alanını Boş Bırakmayın..."), vbCritical, ("TARİH BÖLÜMÜ BOŞ")
TextBox1.SetFocus
Exit Sub
End If
Dim i As Integer
For i = 3 To 25515
If (ActiveSheet.Cells(i, 1) = "") Then
ActiveSheet.Cells(i, 1) = CLng(CDate(TextBox1))
ActiveSheet.Cells(i, 2) = ComboBox1.text
ActiveSheet.Cells(i, 3) = TextBox2.text
ActiveSheet.Cells(i, 4) = TextBox3.text
ActiveSheet.Cells(i, 5) = ComboBox2.text
ActiveSheet.Cells(i, 6) = ComboBox3.text
ActiveSheet.Cells(i, 7) = TextBox4.text
ActiveSheet.Cells(i, 8) = TextBox5.text
ActiveSheet.Cells(i, 9) = TextBox6.text
ActiveSheet.Cells(i, 10) = TextBox7.text
ActiveSheet.Cells(i, 11) = TextBox8.text
ActiveSheet.Cells(i, 12) = ComboBox4.text

MsgBox "Bilgi Eklendi !...", vbOKOnly + vbInformation, "Bilgi Ekleme"

For s = 2 To 8
Controls("textbox" & s) = ""
Next
For a = 1 To 4
Controls("combobox" & a) = ""
Next
MsgBox "YENİ KAYITLAR İÇİN VERİLER SİLİNMİŞTİR.", vbInformation
Range("A3:g65515").Sort Key1:=Range("a3"), Order1:=xlAscending
Sheets("Faaliyet").Select
ActiveWorkbook.Save

sonsutun = "G"
Range("A1").Select
sayi = WorksheetFunction.CountA(Sheets("Faaliyet").Range("a1:a65000")) + 1
yeni = sonsutun + Trim(Str$(Val(sayi)))
With Sheets("Faaliyet").Range("a1:" & yeni)
    .Borders.LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlHairline
    .Borders(xlEdgeLeft).LineStyle = xlHairline
    .Borders(xlEdgeRight).LineStyle = xlHairline
    .Borders(xlEdgeTop).LineStyle = xlHairline
    .Borders(xlInsideVertical).LineStyle = xlHairline
    .Borders(xlInsideHorizontal).LineStyle = xlHairline
End With

Exit Sub
End If
Next i
End Sub