Draw automatic borders using VBA

I have a file , in which every week i will update data. First,i will enter week number, next i will fill up some data on two columns (material no and part id). After that I press update button
i need to see "Outside borders" automatically drawn.
pls help me , how to do that?

Originally Posted by joh46k

I have a file , in which every week i will update data. First,i will enter week number, next i will fill up some data on two columns (material no and part id). After that I press update button
i need to see "Outside borders" automatically drawn.
pls help me , how to do that?

I don't understand your request ! but I try to write a code --> You can test this code ?

Run sub NHM ()

Private Sub CommandButton1_Click()
    NHM
End Sub
'=================================================
Sub NHM()
    Dim rng As Range, myRng As Range
    On Error Resume Next
    Application.ScreenUpdating = False
        Set rng = Range("C2", [C65536].End(3)).SpecialCells(4)
        For Each myRng In rng.Areas
            Noborders myRng.Offset(-1, -1).Resize(myRng.Rows.Count + 1, 12)
            Borders myRng.Offset(-1, -1).Resize(myRng.Rows.Count + 1, 12)
        Next
    Application.ScreenUpdating = True
End Sub
'==========================================================
Private Sub Borders(rng As Range)
Dim Item, Arr()
    Arr = Array(7, 8, 9, 10, 11, 12)
    With rng
        For Each Item In Arr
            If Item = 12 Then
                With .Borders(Item)
                    '.LineStyle = xlContinuous 
                    '.Weight = xlHairline
                End With
            Else
                With .Borders(Item)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
            End If
        Next
    End With
End Sub
'=======================================
Private Sub Noborders(rng As Range)
Dim Arr(), Item
    Arr = Array(5, 6, 7, 8, 9, 10, 11, 12)
    With rng
        For Each Item In Arr
            .Borders(Item).LineStyle = xlNone
        Next
    End With
End Sub

Post this in you worksheet module code and when you make a change to the sheet it will automatically update for you.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim start As Range
  Dim finish As Range
   Application.ScreenUpdating = 0
   If Not Intersect(Target, Range("B:M")) Is Nothing Then
    Range("B2:M" & Cells(Rows.Count, 2).End(xlUp).Row).Borders.LineStyle = 0
      Set start = Range("C2")
      Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
        For j = 1 To 1000
          With Range(Cells(start.Row, 2), Cells(finish.Row - 1, 13))
            For i = 7 To 11
             .Borders(i).LineStyle = 1
            Next i
          End With
            Set start = Range("C" & finish.Row)
            If Cells(start.Row, 3).End(xlDown).Row < Cells(Rows.Count, 2).End(xlUp).Row Then
                Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
            ElseIf y = 1 Then
                GoTo extsub
            Else
               Set finish = Range("C" & Cells(Rows.Count, 2).End(xlUp).Row + 1): y = 1
            End If
        Next
    End If
extsub:
    Application.ScreenUpdating = 1
End Sub

@japandav : i have some questions
1)In future ,if i want to increase the rows where do i need to make changes in the above code.
2) Why the template file working as i wanted but i copy the same code paste in to my original file is not working as i wanted.
Below i attached my excel original file sheet , pls check

Thank you

Where are the week numbers? The Original file is different to the sample, so the code obviously won't work. How do tell each week?

Bump no response

Hi, joh46k,

taking JapanDave´s concept of worksheet change please try this code and see if you may work with it (it will have an effect in the row you change/enter data). Code goes behind the sheet wwhich you want to monitor:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  Dim blnDo As Boolean
  
  If Target.Count > 1 Then Exit Sub
  Application.ScreenUpdating = False
  On Error GoTo extsub
  
  If Not Intersect(Target, Range("B:M")) Is Nothing Then
    With Range("B" & Target.Row & ":M" & Target.Row)
      .Borders.LineStyle = 0
      For i = 7 To 11
        Select Case i
          Case 7, 10, 11
            blnDo = True
          Case 8, 9
            If Cells(Target.Row, "M") = Cells(Target.Row - 1, "M") Then
              Range("B" & Target.Row - 1 & ":M" & Target.Row - 1).Borders(i).LineStyle = 0
              blnDo = False
            Else
              blnDo = True
            End If
        End Select
        If blnDo Then .Borders(i).LineStyle = 1
      Next i
    End With
  End If

extsub:
  Application.ScreenUpdating = True

End Sub

For updating with a Button I would check the date in Column M to build a range for applying borders there.

HTH,
Holger

@hahobe: thank you for your reply man ! i tried ur code but it is not what i wanted .

if you see post #3 , japandave code: His template exactly achieve what i wanted but the problem is ,when i put that code inside my original ALL file(#6) it is not working as in the template that he attached in post #3.
Can you help me , on that ?

Hi, joh46k,

a slight update of the code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  Dim blnDo As Boolean
  
  If Target.Count > 1 Then Exit Sub
  Application.ScreenUpdating = False
  On Error GoTo extsub
  
  If Not Intersect(Target, Range("B:M")) Is Nothing Then
    With Range("B" & Target.Row & ":M" & Target.Row)
      .Borders.LineStyle = 0
      For i = 7 To 11
        Select Case i
          Case 7, 10, 11
            blnDo = True
          Case 8, 9
            If Cells(Target.Row, "M") = Cells(Target.Row - 1, "M") Then
              .Borders(8).LineStyle = 0
              Range("B" & Target.Row + 1 & ":M" & Target.Row + 1).Borders(8).LineStyle = 1
              blnDo = False
            Else
              blnDo = True
            End If
        End Select
        If blnDo Then .Borders(i).LineStyle = 1
      Next i
    End With
  End If

extsub:
  Application.ScreenUpdating = True

End Sub

As the file I was working on shows more than 600 KB I hope I´ve been working on your most current upload.

Ciao,
Holger

@Hahobe : Bro did you tried Dave's post #3 attachment file ? i want something like that.

I tried your file, it creating a border , only if I manually type the data from B to M column . If i tried to copy & paste some data on B to M column , it is not creating a border.

If you tried DAVE'S post#3 file ,you will notice that you can type and also you can copy and pate as value , it will Automatically create a nice border for you .

Hi, joh46k,

Originally Posted by Post#11

If i tried to copy & paste some data on B to M column , it is not creating a border.

Originally Posted by OP

First,i will enter week number

Code will work due to OP (besides that I don´t like areas in a table being left empty). I restricted the code to work for only one cell as entry with

If Target.Count > 1 Then Exit Sub

Deactivating that line will definitely create a RTE when pasting.

What are you pasting (area in the sample)? Is it always equal to a week or not? When will you enter the week number?

i want something like that.

What about answering the questions I just asked for finding out how to rewrite the event?

Ciao,
Holger

OK, try this.

I fixed some other little problems that were nagging me as well. This will update the boarders as you enter data in the table as you update the week No. and the Quarters Column in the B column. If you want it to update from other columns let me know.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim start As Range
    Dim finish As Range
        Application.ScreenUpdating = 0
         a = Range("B2").CurrentRegion
        'If Not Intersect(Target, Range("B:M")) Is Nothing Then
         Cells.Borders.LineStyle = 0
           Set start = Range("C2")
           Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
             For j = 1 To 1000
               With Range(Cells(start.Row, 2), Cells(finish.Row - 1, 13))
                 For i = 7 To 11
                  .Borders(i).LineStyle = 1
                 Next i
               End With
                 Set start = Range("C" & finish.Row)
                 If Cells(start.Row, 3).End(xlDown).Row <= UBound(a) Then
                     Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
                 ElseIf y = 1 Then
                     GoTo extsub
                 Else
                    Set finish = Range("C" & Cells(Rows.Count, 2).End(xlUp).Row + 1): y = 1
                 End If
             Next
        ' End If
extsub:
         Application.ScreenUpdating = 1

End Sub

DAVE : Thanks so much bro ! for you help man it is working correctly and i find where is the problem ?

i have cells that built with formulas that's the reason when every time, i enter the data the border keep expanding until 12000 rows and more than that.
i just now tried to delete that formulas and tried again it works perfectly.

Do you have any suggestion/ideas on how to solve that problem?

Picture is attached below , pls check thank you

Repace the code with this,

You really should have posted an exact copy of the workbook in the first place. I am on my 8th beer right now and it is getting hard to think straight! LOL

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim start As Range
    Dim finish As Range
    Dim a As Long, i As Long, j As Long
        Application.ScreenUpdating = 0
          For i = 2 To 5
            If a < Cells(Rows.Count, i).End(xlUp).Row Then
              a = Cells(Rows.Count, i).End(xlUp).Row
            End If
          Next i
        If Not Intersect(Target, Range("B:M")) Is Nothing Then
         Cells.Borders.LineStyle = 0
           Set start = Range("C2")
           Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
             For j = 1 To 1000
               With Range(Cells(start.Row, 2), Cells(finish.Row - 1, 13))
                 For i = 7 To 11
                  .Borders(i).LineStyle = 1
                 Next i
               End With
                 Set start = Range("C" & finish.Row)
                 If Cells(start.Row, 3).End(xlDown).Row <= a Then
                     Set finish = Range("C" & Cells(start.Row, 3).End(xlDown).Row)
                 ElseIf y = 1 Then
                     GoTo extsub
                 Else
                    Set finish = Range("C" & a + 1): y = 1
                 End If
             Next
         End If
extsub:
         Application.ScreenUpdating = 1

End Sub

Thank you so much Japan dave and HaHoBe ! Great .It is working .

Btw . The code works but i don't know how it's works #15 and #13 . It will be best, if you all write instruction or guide beside the code on how each line works .if not, you can choose important line . by using these symbol ' ' or # #

Once again , Thanks very much .

No worries.

JapanDave : your code works WELL ,only after i delete the blank cells with formula . so How To delete blank cells in that "ALL" sheet coloumns?

I have blank cells in Coloumn B and F to K