VBA draw table line borders every 18 count

[harky]

I not sure if it possible?

VBA draw table line border every 18 count from col T to AF


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]COL T[/TD]
[TD]COL U[/TD]
[TD]COL V[/TD]
[TD]COL W[/TD]
[TD]COL X[/TD]
[TD]COL Y[/TD]
[TD]COL Z[/TD]
[TD]COL AA[/TD]
[TD]COL AB[/TD]
[TD]COL AC[/TD]
[TD]COL AD[/TD]
[TD]COL AE[/TD]
[TD]COL AF[/TD]
[/TR]
[TR]
[TD]ROW1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]A[/TD]
[TD]D[/TD]
[TD]D[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]ROW2[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ROW3[/TD]
[TD]12[/TD]
[TD]10[/TD]
[TD]19[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ROW4[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ROW5[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ROW6[/TD]
[TD]5[/TD]
[TD]3[/TD]
[TD]5[/TD]
[TD]0[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



So row 1 & 2 is add up is 20 count.
It will draw a table border below

Row 4, 5, 6 add up is 18 count
It will draw a table border below

 

[harky]

 

[harky]

cant be done? ? ? ? ? ? ? ?

 

[salim hasan]

Try this macro

Option Explicit


Sub Special_Borders()
 Dim Ar, Sub_Ar
 Cells(2, "T").Resize(20, 13).Borders.LineStyle = 0
 Ar = Array(2, 6, 8, 12, 14, 20)
 For Each Sub_Ar In Ar
    With Cells(Sub_Ar, "T").Resize(, 13).Borders(9)
     .LineStyle = 1
     .Weight = 4
    End With
 Next


End Sub

 

[Peter_SSs]

Give this a try

Sub Line_After_Every_18()
  Dim a As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("T1", Range("T" & Rows.Count).End(xlUp)).Resize(, 13).Value
  uba2 = UBound(a, 2)
  For i = 1 To UBound(a)
    For j = 1 To uba2
      If Len(a(i, j)) Then k = k + 1
      If k = 18 Then
        Range("T" & i).Resize(, 13).Borders(xlEdgeBottom).LineStyle = xlContinuous
        k = 0
        Exit For
      End If
    Next j
  Next i
End Sub

 

[harky]

this only do top few row?

but i had thousand row with data.

Try this macro

Option Explicit


Sub Special_Borders()
 Dim Ar, Sub_Ar
 Cells(2, "T").Resize(20, 13).Borders.LineStyle = 0
 Ar = Array(2, 6, 8, 12, 14, 20)
 For Each Sub_Ar In Ar
    With Cells(Sub_Ar, "T").Resize(, 13).Borders(9)
     .LineStyle = 1
     .Weight = 4
    End With
 Next


End Sub

 

[harky]

yes this!!

but can i start from T22 row? as Row 1 to 21 is so call header.

Can change the line to thicker type?

Give this a try

Sub Line_After_Every_18()
  Dim a As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("T1", Range("T" & Rows.Count).End(xlUp)).Resize(, 13).Value
  uba2 = UBound(a, 2)
  For i = 1 To UBound(a)
    For j = 1 To uba2
      If Len(a(i, j)) Then k = k + 1
      If k = 18 Then
        Range("T" & i).Resize(, 13).Borders(xlEdgeBottom).LineStyle = xlContinuous
        k = 0
        Exit For
      End If
    Next j
  Next i
End Sub

 

[Peter_SSs]

but can i start from T22 row?

Yes, make these 2 changes

 a = Range("T22", Range("T" & Rows.Count).End(xlUp)).Resize(, 13).Value

        Range("T" & i + 21).Resize(, 13).Borders(xlEdgeBottom).LineStyle = xlContinuous

 

[harky]

Thanks!

Yes, make these 2 changes

 a = Range("T22", Range("T" & Rows.Count).End(xlUp)).Resize(, 13).Value

        Range("T" & i + 21).Resize(, 13).Borders(xlEdgeBottom).LineStyle = xlContinuous

 

[salim hasan]

Same macro with variable range

Option Explicit


Sub test()
Dim i%, k%, Arr(), Sub_Arr
k = 1
Const my_max = 50 [SIZE=2][COLOR=#ff0000]'change to wanted number[/COLOR][/SIZE]
For i = 1 To 10000
    ReDim Preserve Arr(1 To k)
    If i = 1 Then
     Arr(i) = 2
    Else
     Arr(i) = IIf(k Mod 2 = 1, Arr(i - 1) + 2, Arr(i - 1) + 4)
    End If
 If Arr(i) > my_max Then Exit For
     k = k + 1
 Next
 Cells(2, "T").Resize(20, 10000).Borders.LineStyle = 0
 For Each Sub_Arr In Arr
    With Cells(Sub_Arr, "T").Resize(, 13).Borders(9)
     .LineStyle = 1
     .Weight = 4
    End With
 Next
End Sub
Erase Arr