Need a macro to draw border

[jb]

Hi Helpers,
I have a table with some data. File "format preserve.xls" is uploaded with thread.
In my sheet, boxes have been created of two cells each with border only around group of two cells.

I need to drag and drop a box from one location to another location within table.

Now when I drag and drop for example I11 and I12 cell to L9 and L10 then right border around I11 and I12 box is removed.

I know that there is no solution to preserve border while drag and drop.

Many times drag and drop is required to be done.

So, is it possible to write a macro that will select outline border from font menu and apply it on old location (e.g. I11 and I12) as well as on new location (e.g. L9 and L10).

Whenever such drag and drop is used, it must apply outline border on old box and new box.

Note: Drag and drop is most convenient and faster way to shift data for me and other users using this sheet.

Thanks.

 

[SirJB7]

Hi, jb!
Put this code in worksheet object module (sheet34).

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ' constants
    Const ki1stRow = 1 '0=even, 1=odd
    ' declarations
    Dim rngSrc As Range, rngTgt As Range
    Dim I As Integer
    ' start
    With Target
        If .Cells.Count <> 2 Or .Rows.Count <> 2 Or .Columns.Count <> 1 Or (.Row Mod 2) <> ki1stRow Then Exit Sub
    End With
    Set rngSrc = Target
    Set rngTgt = Range(ActiveCell, ActiveCell.Offset(1, 0))
    Application.EnableEvents = False
    Debug.Print rngSrc.Address, rngTgt.Address, Target.Address
    I = I + 1
    If I > 10 Then Exit Sub
    ' process
    rngTgt.Copy
    rngSrc.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ' end
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Take care of setting all borders of each box or some of them will lack the bottom line.
Regards!

 

[jb]

SirJB7 I placed the code.
Sir it is not working for all boxes.
For example when I tried to move I16 and I17 to H18 and H19,
above border of I16 and I17 box as well as lower border of H18 and H19 box
disappear.

Sir please help.

 

[SirJB7]

Hi, jb!
Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
Regards!

 

[shahin]

If locations are adjacent to each other then you might give it a try. It's not a workaround but sometimes you might find it useful.

Sub draw_border()
    Selection.CurrentRegion.Borders.LineStyle = xlContinuous
End Sub

 

[SirJB7]

Take care of setting all borders of each box or some of them will lack the bottom line.

Hi, jb!
When I advised you of this it was because I've yet detected some a-bit-weird things about the way borders have been set for "all" boxes. There wasn't an uniform way, some of them have all borders set, others have all but bottom, and I assumed (didn't and won't check) that it was because the uploaded file was a sample and not the definitive model.
So my recommendation is to check that every box (select it and Ctrl-1, borders tab) has all the borders properly set. Then please check again the code and if you happen to find any issue, please come back.
Regards!

 

[jb]

SirJB7 I checked my uploaded file. This excel sheet is part of my bigger excel file. But it is not sample. It contains actual data.
Sir, my excel sheet contains border group of two cells.
say a3,a4 cell makes a group. a4,a5 makes a group. And border is required only around group.

13th row is separator row.

You told me that you have detected some a-bit-weird things about the way borders have been set for "all" boxes. There wasn't an uniform way, some of them have all borders set, others have all but bottom. And to check that every box (select it and Ctrl-1, borders tab) has all the borders properly set.

Sir I checked entire sheet. And I found border around every group.
And moving group of two cell to another empty group of cell is not retaining border to new and old location even after placing code.

Sir help me.

 

[SirJB7]

Hi, jb!
This is your uploaded file with blank rows and columns inserted between every used rectangle of 2x1 cells. 8 rows by 17 columns = 126 blocks. 36 of them with incomplete borders, almost 30%, 28.57%.
Regards!

 

[jb]

SirJB7 I checked my uploaded file. My file is 13.2 KB size which I have uploaded in 1st post of this thread.
Sir, what you have attached is the file with same name but it is 14.3 KB size and it is not same file which I have uploaded in my question.
Sir, please have a look on my file and help me. I have made it sure twice that my sample file is ok.

 

[SirJB7]

Hi, jb!
I neither created a new file nor modified your uploaded file in any form.
I found the borders issue in my first answer, and downloaded again your original file to show you the differences that you couldn't find.
Of course that my file should be greater than yours since I've added intermediate blank columns and rows around each of your 2rowX1col boxes and that was to help you identify the reported problem.
If you don't believe me you can take your original file, repeat the process I did (insertion of cols and rows), and then compare my yellow shaded boxes with what you get as borders in your modified version. Once you realized that there're incomplete borders you may proceed to complete them all, then remove the intermediate cols & rows, and you'll get a properly formatted worksheet to operate with the provided VBA code.
Regards!

 

[jb]

Thanks a ton sir. Now I understand what you want to convey. I will complete all the borders and then I will apply your code.

 

[SirJB7]

Hi, jb!
You can work on my uploaded file, then clear yellow backgrounds, check again all borders, then remove inter row/col blanks.
Regards!

 

[p45cal]

Another way:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
ReInstateBorders Range("A3:Q12,A14:Q19")
Application.ScreenUpdating = True
End Sub


Sub ReInstateBorders(theRange)
For Each are In theRange.Areas
  For rw = 1 To are.Rows.Count - 1 Step 2
    For colm = 1 To are.Columns.Count
      are.Cells(rw, colm).Resize(2).BorderAround xlContinuous
    Next colm
  Next rw
Next are
End Sub

Not in the file, but to avoid unnecessary screen flicker, or updating of borders when altering the sheet in areas which aren't part of the tables you could change to:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TheTables As Range
Set TheTables = Range("A3:Q12,A14:Q19")
If Not Intersect(Target, TheTables) Is Nothing Then
  Application.ScreenUpdating = False
  ReInstateBorders TheTables
  Application.ScreenUpdating = True
End If
End Sub

 

[jb]

Hi, jb!
You can work on my uploaded file, then clear yellow backgrounds, check again all borders, then remove inter row/col blanks.
Regards!

Hi SirJB7,
Sorry to disturb you once again. But unfortunately, the solution not worked even though I completed all borders, removed extra rows and columns and then applied your code. But still borders disappear.

I am attaching the file for your reference.
In this file, "format" sheet contains the same sheet in which you identified some boxes without borders.
"With border" sheet contains all boxes with borders.
"table" sheet contains, table with extra rows and columns removed.
"test" sheet copy of "table" sheet but only change is K18 K19 moved to J18 J19. Bottom border of K18 K19 disappear.

 

[SirJB7]

Hi, jb!
Check the uploaded file at worksheet "table". Remember moving the code to the worksheet that you'll finally use. I removed the debug lines from the code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ' constants
    Const ki1stRow = 1 '0=even, 1=odd
    ' declarations
    Dim rngSrc As Range, rngTgt As Range
    ' start
    Application.EnableEvents = False
    With Target
        If .Cells.Count <> 2 Or .Rows.Count <> 2 Or .Columns.Count <> 1 Or (.Row Mod 2) <> ki1stRow Then Exit Sub
    End With
    Set rngSrc = Target
    Set rngTgt = Range(ActiveCell, ActiveCell.Offset(1, 0))
    Debug.Print rngSrc.Address, rngTgt.Address, Target.Address, Application.EnableEvents
    ' process
    rngTgt.Copy
    rngSrc.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    rngSrc.Copy
    rngTgt.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ' end
    Application.EnableEvents = True
    Application.CutCopyMode = False
End Sub

Regards!

 

[p45cal]

SirJB7, I think one problem is that there are 2 tables on the sheet, one starting on an even-numbered row and one starting on an odd-numbered row. With the line which includes:
Or (.Row Mod 2) <> ki1stRow Then Exit Sub
operating on one of the two tables will always exit at this point… won't it?

 

[jb]

SirJB7, it is still not working. Border disappear at some places.

So I am thinking on a solution which can identify old box of table from where data dragged and new box where data is dropped. After that just draw border around them. Is it possible?
OR
Will it be ok if I write a macro which will select each box and draw border? This macro will run when any cell of table get changed?

 

[SirJB7]

Hi, p45cal!
I don't actually remember why I did it in such way, I can only thing that the middle line was part of an incomplete design. Let the OP clarify this. However, a little tricky adjustment maybe adding a new line after actual 13th and make it hidden. Or modify the code correctly.
Regards!

 

[SirJB7]

Hi, jb!
We were just talking about it with p45cal.
A doubt, line 13 is necessary, can we add a 14th line and hide it?
Regards!

 

[p45cal]

jb, what was wrong with my offering in msg#13? There's been no comment.
For the more recent files being attached here, that range line would change from:
Set TheTables = Range("A3:Q12,A14:Q19")
to:
Set TheTables = Range("B3:R12,B14:R19")

 

[jb]

Hi, jb!
We were just talking about it with p45cal.
A doubt, line 13 is necessary, can we add a 14th line and hide it?
Regards!

Sir, sorry for late reply. But yes line 13 is necessary. This excel sheet is a timetable of my school. Line 13 will contain message "Break Time". Above table shows lectures before break and below table shows lectures after break.

Now, 14th line can be added in worst case. This sheet is part of my excel file and other sheets contains many formulas based on this table. I need to correct all the formulas. But yes if adding 14th line is the only option then I have to do correction in all other worksheets.

Sir, I am attaching my actual file with this reply. At your convenience, please have a look in this file. I have tried and worked a lot to make an excel file which can help a lot in preparing time table.

 

[jb]

jb, what was wrong with my offering in msg#13? There's been no comment.
For the more recent files being attached here, that range line would change from:
Set TheTables = Range("A3:Q12,A14:Q19")
to:
Set TheTables = Range("B3:R12,B14:R19")

Sir, thanks you so much for helping me. But sir, I couldn't understand the solution that you provided in msg#13. means you provided two codes and I did't understand where to paste them in my file.

That's why I have not commented yet. Can you help me bit more?

Sir, I am attaching my actual file with this reply. At your convenience, please have a look in this file. I have tried and worked a lot to make an excel file which can help a lot in preparing time table.

 

[p45cal]

There are more than 30 sheets in your attachment. On which sheets do you want this to work?

In the attached, because there are perhaps so many sheets involved, I've tweaked the code, and where it's placed in the file, to the ThisWorkbook code-module.
It works on the following sheets:
MEB
timetable
FYBCA
SYBCA
TYBCA
FYBCOMA
FYBCOMB
SYBCOMA
SYBCOMB
TYBCOMA
TYBCOMB
FYBBA
SYBBA
TYBBA
FYBBAI
SYBBAI
TYBBAI
FOYBBAI
It will now re-instate the correct borders to those tables in those sheets. For those interested, the code is:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim TheTables As Range
Sheetnames = Array("MEB", "timetable", "FYBCA", "SYBCA", "TYBCA", "FYBCOMA", "FYBCOMB", "SYBCOMA", _
                  "SYBCOMB", "TYBCOMA", "TYBCOMB", "FYBBA", "SYBBA", "TYBBA", "FYBBAI", "SYBBAI", _
                  "TYBBAI", "FOYBBAI")
zz = Application.Match(Sh.Name, Sheetnames, 0)
If Not IsError(zz) Then
  Select Case zz
    Case 1 'MEB
      Set TheTables = Sh.Range("A5:G12,J5:P12,J14:P19,A14:G19")
    Case 2 'timetable
      Set TheTables = Sh.Range("A7:Q16,A18:Q23")
    Case 3 To 18 'all the rest
      Set TheTables = Sh.Range("A8:G17,A19:G24")
  End Select
  If Not Intersect(Target, TheTables) Is Nothing Then
    Application.ScreenUpdating = False
    ReInstateBorders TheTables
    Application.ScreenUpdating = True
  End If
End If
End Sub

Sub ReInstateBorders(theRange)
For Each are In theRange.Areas
  For rw = 1 To are.Rows.Count - 1 Step 2
    For colm = 1 To are.Columns.Count
      are.Cells(rw, colm).Resize(2).BorderAround xlContinuous
    Next colm
  Next rw
Next are
End Sub