Set borders dynamically around a range - vba

[kelly mort]

Hello geniuses,
I am looking for a vba script that can set borders like the image here.
The data can grow or shrink. And when it does, I want to adapt to it with the borders.

I hope someone can fix it for me.

Thanks in advance.

 

[Peter_SSs]

The data can grow or shrink. And when it does, I want to adapt to it with the borders.

Do you mean automatically, or if the vba code is run again?
If automatically, would you consider Conditional Formatting instead of vba?

You say the data can grow/shrink but it is not clear what you mean. In your sample (BTW, XL2BB would be better so we can copy for testing) all the sections are 7 rows and 4 columns. Does grow/shrink mean that the number of rows and/or columns in a section can change or does it simply mean that the number of sections can change?

 

[kelly mort]

Thanks @Peter_SSs for your questions.
Anything that can set the borders for me is allowed.
Like I said before, a vba script is filling the sheet in the diagram and the data can grow in rows but not in columns.
The maximum rows that could emerge is 30.
And this is dependent on the number of rows that have dates attached - the various payments.

So whatever - vba or conditional formatting - works is fine for me.
I hope I was able to express myself well enough.
Thanks

 

[Peter_SSs]

a vba script is filling the sheet

In that case it would probably be simplest to have the vba apply the borders as it fills the sheet. Could you post the code so that we could assess how to adapt it for this extra task?

 

[kelly mort]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim K, H, L, N&, V, R&, C%
        If Target.Address <> "$B$1" Then Exit Sub
        Application.EnableEvents = False
        Me.UsedRange.Offset(1).Clear
        If IsEmpty(Target) Then Application.EnableEvents = True: Exit Sub
        K = [{2,3,4,15}]
        H = Application.Index(Worksheets(1).UsedRange.Rows(1), , K)
        L = Application.Index(Worksheets(1).UsedRange.Rows(1), , [{16,16,17,17}])
    For N = 1 To Me.Index - 1
        With Sheets(N).UsedRange
                V = Application.Match(Target, .Columns(1), 0)
            If IsNumeric(V) Then
                Cells(R + 2, 1).Value2 = .Parent.Name
                Cells(R + 3, 1).Resize(, UBound(K)).Value2 = H
                R = R + 4
                Cells(R, 1).Resize(, UBound(K)).Value2 = Application.Index(.Rows(V), , K)
            For C = 5 To 13 Step 2
                If IsEmpty(.Cells(V, C)) Then Exit For
                R = R + 1
                Cells(R, 2).Resize(, 2).Value = .Cells(V, C).Resize(, 2).Value
            Next
                R = R + 1
                L(2) = .Cells(V, 16).Value2:  L(4) = .Cells(V, 17).Value2
                Cells(R, 1).Resize(, UBound(L)).Value2 = L
            End If
        End With
    Next
        Application.EnableEvents = True
End Sub

 

[Peter_SSs]

Thanks for the code. Try this with a copy of your workbook.
I have marked two added lines and one added section with asterisks.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim K, H, L, N&, V, R&, C%
    Dim RowStart As Long, Rws As Long '*******************************
        If Target.Address <> "$B$1" Then Exit Sub
        Application.EnableEvents = False
        Me.UsedRange.Offset(1).Clear
        If IsEmpty(Target) Then Application.EnableEvents = True: Exit Sub
        K = [{2,3,4,15}]
        H = Application.Index(Worksheets(1).UsedRange.Rows(1), , K)
        L = Application.Index(Worksheets(1).UsedRange.Rows(1), , [{16,16,17,17}])
    For N = 1 To Me.Index - 1
        With Sheets(N).UsedRange
                V = Application.Match(Target, .Columns(1), 0)
            If IsNumeric(V) Then
                RowStart = R + 2 '*******************************
                Cells(R + 2, 1).Value2 = .Parent.Name
                Cells(R + 3, 1).Resize(, UBound(K)).Value2 = H
                R = R + 4
                Cells(R, 1).Resize(, UBound(K)).Value2 = Application.Index(.Rows(V), , K)
            For C = 5 To 13 Step 2
                If IsEmpty(.Cells(V, C)) Then Exit For
                R = R + 1
                Cells(R, 2).Resize(, 2).Value = .Cells(V, C).Resize(, 2).Value
            Next
                R = R + 1
                L(2) = .Cells(V, 16).Value2:  L(4) = .Cells(V, 17).Value2
                Cells(R, 1).Resize(, UBound(L)).Value2 = L
                '*******************************
                Rws = R - RowStart + 1
                With Range("A" & RowStart).Resize(Rws, 4)
                  .BorderAround xlContinuous
                  .Rows(2).BorderAround xlContinuous
                  .Rows(3).BorderAround xlContinuous
                  .Rows(Rws).BorderAround xlContinuous
                  .Offset(1).Resize(Rws - 1).Borders(xlInsideVertical).LineStyle = xlContinuous
                End With
                '*******************************
            End If
        End With
    Next
        Application.EnableEvents = True
End Sub

 

[kelly mort]

@Peter_SSs
The code gave me this:

Instead of what I wanted :

Is it possible to get what I wanted?

 

[Dossfm0q]

Hi
what About, need some touch

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rng As Range, TblRng As Range, RwRng As Range
Application.EnableEvents = False
Application.ScreenUpdating = False

Set TblRng = Columns("A:D").Cells

If Not Intersect(Target, TblRng) Is Nothing Then

    For Each Rng In Target
 
        With Rng
         Set RwRng = TblRng.Rows(.Row).Cells
        If WorksheetFunction.CountA(RwRng) = 0 Then
        
            For B = 7 To 12
            If B <> 8 And B <> 9 Then
            RwRng.Borders(B).LineStyle = xlNone
            End If
            Next
        ElseIf WorksheetFunction.CountA(RwRng) = 1 And .MergeCells = False Then
            
            For B = 7 To 10
                With RwRng.Borders(B)
                    .LineStyle = xlContinuous
                    .Color = RGB(0, 0, 0)
                    .Weight = xlThin
                End With
            Next
        ElseIf .MergeCells = True Then
            
            For B = 7 To 10
                With .MergeArea.Borders(B)
                    .LineStyle = xlContinuous
                    .Color = RGB(0, 0, 0)
                    .Weight = xlThin
                End With
            Next
        ElseIf WorksheetFunction.CountA(RwRng) = 4 Or (RwRng.Cells(1, 1) <> "" And RwRng.Cells(1, RwRng.Columns.Count) <> "") Then
            
            For B = 7 To 12
                With RwRng.Borders(B)
                    .LineStyle = xlContinuous
                    .Color = RGB(0, 0, 0)
                    .Weight = xlThin
                End With
            Next
        ElseIf WorksheetFunction.CountA(RwRng) = 2 Then
        
            For B = 7 To 12
            RwRng.Borders(B).LineStyle = xlNone
            
            Next
                For B = 7 To 12
                If RwRng.Cells(1, 1).Offset(-1, 0) <> "" And RwRng.Cells(1, RwRng.Columns.Count).Offset(-1, 0) <> "" Then
                
                If B <> 9 Then
                    With RwRng.Borders(B)
                        .LineStyle = xlContinuous
                        .Color = RGB(0, 0, 0)
                        .Weight = xlThin
                    End With
                End If
                ElseIf RwRng.Cells(1, 1).Offset(1, 0) <> "" And RwRng.Cells(1, RwRng.Columns.Count).Offset(1, 0) <> "" Then
                
                If B <> 8 Then
                    With RwRng.Borders(B)
                        .LineStyle = xlContinuous
                        .Color = RGB(0, 0, 0)
                        .Weight = xlThin
                    End With
                End If
                Else
                If B <> 8 And B <> 9 Then
                    With RwRng.Borders(B)
                        .LineStyle = xlContinuous
                        .Color = RGB(0, 0, 0)
                        .Weight = xlThin
                    End With
                End If
            End If
                
                Next
            
        End If
        
        
        End With
        
    Next

End If

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[kelly mort]

@Peter_SSs
Sorry for the earlier post. Your code worked perfectly!
I was having a code that was overriding yours.

Everything is cool now.

One last thing:
How do I bold the first three rows in each group and the last row?

Then also I want to get all values set to 2 decimal places.

After that I also want to get the data right - aligned except row 1.

Thanks again for your time.

 

[Peter_SSs]

@Peter_SSs
Sorry for the earlier post. Your code worked perfectly!
I was having a code that was overriding yours.

Cheers. Glad you got that sorted.

One last thing:

You mean "Three last things .."

Add this marked section where shown

                  .Rows(Rws).BorderAround xlContinuous
                  .Offset(1).Resize(Rws - 1).Borders(xlInsideVertical).LineStyle = xlContinuous
                  '#############
                  Union(.Rows("1:3"), .Rows(Rws)).Font.Bold = True
                  .NumberFormat = "0.00"
                  .Offset(1).Resize(Rws - 1).HorizontalAlignment = xlRight
                  '#############
                End With
            End If