Excel'de border çizme

[Hasan Şalcıav]

Merhaba,
Kapı girişlerindeki cihazlardan aylık rapor çekiyorum ve excel olarak dışarı aktarıyorum. Program xls olarak aktarıyor. Tablo 2 parçadan oluşuyor, 1 başlık kısmı, 2 giriş-çıkış saatlerinin yazdığı kısım. Tablo dışındaki yerler beyaz, tablo ise silik ve kalın bir border ile çizilmiş hücrelerden oluşuyor ama her hücre çizilmiş olmuyor, bazıları border'sız Bu tablolardan 71 tane var. Ben her ay 2 bölümü de ayrı ayrı işaretleyip kenarlarındaki border'ları ince pencere olana border ile değiştiriyorum.
Bu sorunlu tablo https://drive.google.com/open?id=1dnvDEs0mwRmYZFd-lTZJHtUlWtWDbouB
Bu da düzeltilmiş olanı https://drive.google.com/open?id=1f3CUP_qTk3GFud8aNHkBlgEqMhzQLrGC

Her kullanıcı için satır sayıları eşit değil, kaç kez girip çıktıysa, o kadar artıyor, minimum ay içindeki gün sayısı kadar satır oluyor.
Bu çerçeveleri otomatik çizebilecek bir yöntem var mıdır?

Teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

3 kullanıcı için ham bir excel tablosu paylaşırsanız makro yazılabilir.

 

[Hasan Şalcıav]

Merhaba,

3 kullanıcı için ham bir excel tablosu paylaşırsanız makro yazılabilir.

Çok teşekkür ederim Korhan Bey.

Buradan indirebilirsiniz.

Ocak 2020 Kapı Kartları.xlsx

drive.google.com

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Tabloya_Border_Ekle()
    Dim X As Long, Son As Long, Toplam_Bul As Range
        
    Application.ScreenUpdating = False
        
    Cells.Borders.LineStyle = False
    Range("A1:B2").Borders.LineStyle = 1

    Son = Cells(Rows.Count, 1).End(3).Row

    For X = 4 To Son
        If Cells(X, 1) = "Kart No:" Then
            Range("A" & X & ":F" & X + 3).Borders.LineStyle = 1
            Set Toplam_Bul = Range("A" & X & ":L" & Rows.Count).Find("TOPLAM:", , , xlPart)
            If Not Toplam_Bul Is Nothing Then
                Range("A" & X + 4 & ":L" & Toplam_Bul.Row).Borders.LineStyle = 1
                X = Toplam_Bul.Row + 1
            End If
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Hasan Şalcıav]

Deneyiniz.

Option Explicit

Sub Tabloya_Border_Ekle()
    Dim X As Long, Son As Long, Toplam_Bul As Range
       
    Application.ScreenUpdating = False
       
    Cells.Borders.LineStyle = False
    Range("A1:B2").Borders.LineStyle = 1

    Son = Cells(Rows.Count, 1).End(3).Row

    For X = 4 To Son
        If Cells(X, 1) = "Kart No:" Then
            Range("A" & X & ":F" & X + 3).Borders.LineStyle = 1
            Set Toplam_Bul = Range("A" & X & ":L" & Rows.Count).Find("TOPLAM: ", , , xlWhole)
            If Not Toplam_Bul Is Nothing Then
                Range("A" & X + 4 & ":L" & Toplam_Bul.Row).Borders.LineStyle = 1
                X = Toplam_Bul.Row + 1
            End If
        End If
    Next

    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Bey merhaba,
Öncelikle çok teşekkür ederim.
Kodu denedim, tablonun başlık kısmını yaptı, giriş çıkışların olduğu tablodaki tüm border'ları sildi. Saat kısmının border'larını nasıl yapabilirim?

Ocak 2020 Kapı Kartları.xlsm

drive.google.com

 

[Korhan Ayhan]

Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[Hasan Şalcıav]

Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Mükemmel!
Çok teşekkür ederim Korhan Bey.
Saygılarımla.