kenarlıklar hakkında

[aptillah]

bu sitede gerçekten çok şey öğrendim yardımlarınız için tekrar teşekkür ederim . dershanede çalışıyorum ve bir yoklama programı yaptım yardımlarınızla . yardım istediğim konu ise aktar butonuna basınca tüm öğrencileri sınıfna göre aktarıyor fakat şunu merak ediyorum aktardıktan snrada en son satırın kenarlıklarını üsttekileri baz alarak yapabilirmi mesela 19 kişi olan si sınıf 18 e düştügünde otomaik olarak kenarlık silinebilirmi ?

 

[Ömer]

Merhaba,

Kodları aşağıdaki gibi değiştirerek deneyiniz.

Sub aktar()
 
Dim i As Integer, So As Worksheet, r As Long, sat1 As Long
 
Set So = Sheets("öğrenciler")
 
For i = 1 To ActiveWorkbook.Sheets.Count
    With Sheets(i)
        If .Name <> "öğrenciler" And .Name <> "DERSLER" Then
            sat1 = 5
            .Range("A5:I52").ClearContents
            [COLOR=blue].Range("A5:S52").Borders.LineStyle = 0[/COLOR]
            MsgBox .Name
                For r = 2 To So.Cells(Rows.Count, "A").End(xlUp).Row
                    If So.Cells(r, "A").Value = "04" & .Name Then
                        .Cells(sat1, "A").Value = sat1 - 4
                        .Cells(sat1, "B").Value = So.Cells(r, "B").Value
                        .Cells(sat1, "D").Value = So.Cells(r, "C").Value
                        .Cells(sat1, "I").Value = So.Cells(r, "D").Value
                        sat1 = sat1 + 1
                    End If
                Next r
            .Cells(sat1 + 6, "B").Value = "Toplam Öğrenci Sayısı….:" & sat1 - 5
           [COLOR=blue].Range("A4:M" & sat1).Borders(xlInsideHorizontal).LineStyle = 1[/COLOR]
[COLOR=blue]           .Range("N5:S" & sat1 - 1).Borders.LineStyle = 1[/COLOR]
        End If
    End With
Next i
MsgBox "işlem tamam"
End Su

.

 

[aptillah]

ömer hocam ildilendiğin için teşekkürler yanlız verdiğin makro bütün kenarlıklaır çiziyor benim istedğim tekrar bakarsan kenarlıklara isim ve soyismi bir kenarlıkta tutması lazım yani 1. sıradaki öğrenicin kenarlıkları nasılsa aynısı olması gerekiyor...

 

[Ömer]

#2 nolu mesajı güncelledim. Tekrar deneyiniz.

.

 

[AS3434]

Sayın aptillah

Sayfa yapılarınızı düzenlerseniz bence sorun daha kolay çözülür.

Sarı renkli sayfa sütun genişliklerini inceleyin. Diğer sayfalarıda ona uydurun.

Sayın Ömer'in kodlarının uygulanmış hali ile dosyayı inceleyin.

Kodları şöyle revize edin. (Kırmızı yerler.)

Sub aktar()
 
Dim i As Integer, So As Worksheet, r As Long, sat1 As Long
 
Set So = Sheets("öğrenciler")
 
For i = 1 To ActiveWorkbook.Sheets.Count
With Sheets(i)
If .Name <> "öğrenciler" And .Name <> "DERSLER" Then
sat1 = 5
.Range("A5:I52").ClearContents
.Range("A5:[COLOR=red]j[/COLOR]52").Borders.LineStyle = 0
MsgBox .Name
For r = 2 To So.Cells(Rows.Count, "A").End(xlUp).Row
If So.Cells(r, "A").Value = "04" & .Name Then
.Cells(sat1, "A").Value = sat1 - 4
.Cells(sat1, "B").Value = So.Cells(r, "B").Value
.Cells(sat1, "[COLOR=red]c[/COLOR]").Value = So.Cells(r, "C").Value
.Cells(sat1, "[COLOR=red]d[/COLOR]").Value = So.Cells(r, "D").Value
sat1 = sat1 + 1
End If
Next r
.Cells(sat1 + 6, "B").Value = "Toplam Öğrenci Sayısı….:" & sat1 - 5
.Range("A5:[COLOR=red]j[/COLOR]" & sat1 - 1).Borders.LineStyle = 1
End If
End With
Next i
MsgBox "işlem tamam"
End Sub

 

[aptillah]

#2 nolu mesajı güncelledim. Tekrar deneyiniz.

.

ömer hocam gönderdiğiniz kodla bikaç bişey ekleyerek istediğimi yaptım yardımlarınız için teşekkürler...