1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need a macro to draw border

Discussion in 'VBA Macros' started by jb, Jul 14, 2017.

  1. jb

    jb Member

    Messages:
    112
    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.

    Attached Files:

  2. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    Hi, jb!
    Put this code in worksheet object module (sheet34).
    Code (vb):
    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!
    ThrottleWorks likes this.
  3. jb

    jb Member

    Messages:
    112
    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.
  4. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    Hi, jb!
    Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
    Regards!
  5. shahin

    shahin Active Member

    Messages:
    433
    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.
    Code (vb):

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

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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!
  7. jb

    jb Member

    Messages:
    112
    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.
  8. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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!

    Attached Files:

  9. jb

    jb Member

    Messages:
    112
    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.
  10. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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!
  11. jb

    jb Member

    Messages:
    112
    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.
  12. SirJB7

    SirJB7 Excel Rōnin

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

    p45cal Well-Known Member

    Messages:
    788
    Another way:
    Code (vb):
    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:
    Code (vb):
    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

    Attached Files:

    Last edited: Jul 29, 2017
  14. jb

    jb Member

    Messages:
    112
    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.

    Attached Files:

  15. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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:
    Code (vb):
    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!

    Attached Files:

  16. p45cal

    p45cal Well-Known Member

    Messages:
    788
    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?
  17. jb

    jb Member

    Messages:
    112
    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?
  18. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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!
  19. SirJB7

    SirJB7 Excel Rōnin

    Messages:
    8,894
    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!
  20. p45cal

    p45cal Well-Known Member

    Messages:
    788
    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")
  21. jb

    jb Member

    Messages:
    112
    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.

    Attached Files:

    Last edited: Aug 10, 2017
  22. jb

    jb Member

    Messages:
    112

    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.

    Attached Files:

    Last edited: Aug 10, 2017
  23. p45cal

    p45cal Well-Known Member

    Messages:
    788
    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:
    Code (vb):
    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

    Attached Files:

    Last edited: Aug 10, 2017

Share This Page