Copy only borders of a range to new range

Copy all borders of a selected range to a different range:

I want to copy only the borders of a selected range to a different range. In other words it would behave something like format painter, but ONLY copy paste the borders.

Is this even possible?

I could not find a solution to this problem even though it seems like many people have similar problems. I could do this if all the borders, internal and frame, are the same, but if they are not, I just end up with a new range with one type of border.

The way I would like to use it is to ask for a range to select, then copy the borders of this range to different ranges (same size as original range).

Kind regards,
vanhunk

It is only possible using VBA, but requires hard coding work like:

Code:

---

        oNewCell.Borders(xlDiagonalDown).LineStyle = oCell.Style.Borders(xlDiagonalDown).LineStyle
        oNewCell.Borders(xlDiagonalUp).LineStyle = oCell.Style.Borders(xlDiagonalUp).LineStyle
        oNewCell.Borders(xlEdgeBottom).LineStyle = oCell.Style.Borders(xlEdgeBottom).LineStyle
        oNewCell.Borders(xlEdgeLeft).LineStyle = oCell.Style.Borders(xlEdgeLeft).LineStyle
        oNewCell.Borders(xlEdgeRight).LineStyle = oCell.Style.Borders(xlEdgeRight).LineStyle
        oNewCell.Borders(xlEdgeTop).LineStyle = oCell.Style.Borders(xlEdgeTop).LineStyle
        oNewCell.Borders(xlLeft).LineStyle = oCell.Style.Borders(xlLeft).LineStyle
        oNewCell.Borders(xlRight).LineStyle = oCell.Style.Borders(xlRight).LineStyle
        oNewCell.Borders(xlTop).LineStyle = oCell.Style.Borders(xlTop).LineStyle
        oNewCell.Borders(xlBottom).LineStyle = oCell.Style.Borders(xlBottom).LineStyle
        oNewCell.Borders(xlDiagonalDown).ColorIndex = oCell.Style.Borders(xlDiagonalDown).ColorIndex
        oNewCell.Borders(xlDiagonalUp).ColorIndex = oCell.Style.Borders(xlDiagonalUp).ColorIndex
        oNewCell.Borders(xlEdgeBottom).ColorIndex = oCell.Style.Borders(xlEdgeBottom).ColorIndex
        oNewCell.Borders(xlEdgeLeft).ColorIndex = oCell.Style.Borders(xlEdgeLeft).ColorIndex
        oNewCell.Borders(xlEdgeRight).ColorIndex = oCell.Style.Borders(xlEdgeRight).ColorIndex
        oNewCell.Borders(xlEdgeTop).ColorIndex = oCell.Style.Borders(xlEdgeTop).ColorIndex
        oNewCell.Borders(xlLeft).ColorIndex = oCell.Style.Borders(xlLeft).ColorIndex
        oNewCell.Borders(xlRight).ColorIndex = oCell.Style.Borders(xlRight).ColorIndex
        oNewCell.Borders(xlTop).ColorIndex = oCell.Style.Borders(xlTop).ColorIndex
        oNewCell.Borders(xlBottom).ColorIndex = oCell.Style.Borders(xlBottom).ColorIndex

---

You might use:

Code:

---

Sub M_snb()
  ActiveWorkbook.Styles("Normal").IncludeBorder = False
 
  With Selection
      .Copy
      With .Offset(20)
        .PasteSpecial -4122
        .Style = "Normal"
      End With
    End With
   
  ActiveWorkbook.Styles("Normal").IncludeBorder = True
End Sub

---

@snb:
Thank you sir, I don't understand the code yet (i.e. what each item does exactly), but it is working fantastic.

@Jan Karel Pieterse:
Thank you sir.
For this to work is to do it for each cell in the range. Otherwise it just treats it as a block and you can't have different styles inside the block. I was thinking of somehow stepping through each cell in the range (array style) and paste to its corresponding cell in the new range. I have not yet figured out how to actually do it. Maybe you have an idea.
Regards,
vanhunk

The basic code is working well now. I adapted the code from snb and JKP a bit.

See below:

Short version based on snb’s code:

Code:

---

Sub M_snbMOD()
  Dim myRangeC As Range
  Dim myRangeP As Range
 
  ActiveWorkbook.Styles("Normal").IncludeBorder = False
 
  'The following lines store a selected range of cells in the variable "myRangeC"
  'which will be the range used to copy the border linestyle from:
  Set myRangeC = Application.InputBox(Prompt:="Select Range", _
          Title:="Select Range with Borders to Copy", Type:=8)
 
  'The following lines store a selected range of cells in the variable "myRangeP"
  'which will be the range used to copy the border linestyle to:
 
  Set myRangeP = Application.InputBox(Prompt:="Select Range", _
          Title:="Select Range to Apply Borders", Type:=8)
     
        myRangeC.Copy
        myRangeP.PasteSpecial -4122
        myRangeP.Style = "Normal"
         
    ActiveWorkbook.Styles("Normal").IncludeBorder = True
  End Sub

---

Long version based on JKP’s code:

Code:

---

Sub CopyBordersOnly()
  Dim myRangeC As Range
  Dim myRangeP As Range
  Dim i As Integer
 
  ActiveWorkbook.Styles("Normal").IncludeBorder = False
 
  'The following lines store a selected range of cells in the variable "myRangeC"
  'which will be the range used to copy the border linestyle from:
  Set myRangeC = Application.InputBox(Prompt:="Select Range", _
          Title:="Select Range with Borders to Copy", Type:=8)
 
  'The following lines store a selected range of cells in the variable "myRangeP"
  'which will be the range used to copy the border linestyle to:
 
  Set myRangeP = Application.InputBox(Prompt:="Select Range", _
          Title:="Select Range to Apply Borders", Type:=8)
 
  Set myRangeP = myRangeP.Resize(myRangeC.Rows.Count, myRangeC.Columns.Count)
 
  For i = 1 To myRangeC.Count
      myRangeP(i).Borders(xlEdgeLeft).LineStyle = myRangeC(i).Borders(xlEdgeLeft).LineStyle
      myRangeP(i).Borders(xlEdgeTop).LineStyle = myRangeC(i).Borders(xlEdgeTop).LineStyle
      myRangeP(i).Borders(xlEdgeBottom).LineStyle = myRangeC(i).Borders(xlEdgeBottom).LineStyle
      myRangeP(i).Borders(xlEdgeRight).LineStyle = myRangeC(i).Borders(xlEdgeRight).LineStyle
 
      myRangeP(i).Borders(xlEdgeLeft).Weight = myRangeC(i).Borders(xlEdgeLeft).Weight
      myRangeP(i).Borders(xlEdgeTop).Weight = myRangeC(i).Borders(xlEdgeTop).Weight
      myRangeP(i).Borders(xlEdgeBottom).Weight = myRangeC(i).Borders(xlEdgeBottom).Weight
      myRangeP(i).Borders(xlEdgeRight).Weight = myRangeC(i).Borders(xlEdgeRight).Weight
  Next i
 
  End Sub

---

Thank you very much!

Just selecting the left upper cell of the 'To' range is sufficient.

Code:

---

Sub M_snb()
    ActiveWorkbook.Styles("Normal").IncludeBorder = False
     
    With Application.InputBox("Select Range", "Select Cell to Apply Borders to",,,,,,8)
        Application.InputBox("Select Range", "Select Range with Borders to Copy",,,,,,8).Copy
        .PasteSpecial -4122
        .Style = "Normal"
    End With
         
    ActiveWorkbook.Styles("Normal").IncludeBorder = True
End Sub

---

@snb:
Thank you for the response, there is a problem however. The code below copies other formatting as well, not only borders, same with previous code.

Regards,
Henk

Quote:

---

Originally Posted by snb

Just selecting the left upper cell of the 'To' range is sufficient.

Code:

---

Sub M_snb()
    ActiveWorkbook.Styles("Normal").IncludeBorder = False
     
    With Application.InputBox("Select Range", "Select Cell to Apply Borders to",,,,,,8)
        Application.InputBox("Select Range", "Select Range with Borders to Copy",,,,,,8).Copy
        .PasteSpecial -4122
        .Style = "Normal"
    End With
         
    ActiveWorkbook.Styles("Normal").IncludeBorder = True
End Sub

---

---

This is the code I ended up using (for now):

Code:

---

Sub CopyBordersOnlyLV()
Dim myRangeC As Range
Dim myRangeP As Range
Dim i As Integer

ActiveWorkbook.Styles("Normal").IncludeBorder = False

'The following lines store a selected range of cells in the variable "myRangeC"
'which will be the range used to copy the border linestyle from:
 Set myRangeC = Application.InputBox(Prompt:="Select Range", _
        Title:="Select Range with Borders to Copy", Type:=8)

'The following lines store a selected range of cells in the variable "myRangeP"
'which will be the range used to copy the border linestyle to:

PasteRange:
 Set myRangeP = Application.InputBox(Prompt:="Select Range", _
        Title:="Select Range to Apply Borders", Type:=8)

 Set myRangeP = myRangeP.Resize(myRangeC.Rows.Count, myRangeC.Columns.Count)

For i = 1 To myRangeC.Count
    myRangeP(i).Borders(xlEdgeLeft).LineStyle = myRangeC(i).Borders(xlEdgeLeft).LineStyle
    myRangeP(i).Borders(xlEdgeTop).LineStyle = myRangeC(i).Borders(xlEdgeTop).LineStyle
    myRangeP(i).Borders(xlEdgeBottom).LineStyle = myRangeC(i).Borders(xlEdgeBottom).LineStyle
    myRangeP(i).Borders(xlEdgeRight).LineStyle = myRangeC(i).Borders(xlEdgeRight).LineStyle
 
    myRangeP(i).Borders(xlEdgeLeft).Weight = myRangeC(i).Borders(xlEdgeLeft).Weight
    myRangeP(i).Borders(xlEdgeTop).Weight = myRangeC(i).Borders(xlEdgeTop).Weight
    myRangeP(i).Borders(xlEdgeBottom).Weight = myRangeC(i).Borders(xlEdgeBottom).Weight
    myRangeP(i).Borders(xlEdgeRight).Weight = myRangeC(i).Borders(xlEdgeRight).Weight
Next i

Dim Answer As String
 
 Answer = MsgBox("Do you want to continue?", _
            vbYesNo + 256 + vbQuestion, "Continue Pasting Borders")
   
 If Answer = vbNo Then Exit Sub
   
 If Answer = vbYes Then
    GoTo PasteRange
 End If
 
End Sub

---

It doesn't with:

Code:

---

Sub M_snb()
    ActiveWorkbook.Styles("Normal").IncludeBorder = False
     
    Set R1 = Application.InputBox("Select Range", "Select Range with Borders to Copy", , , , , , 8)

    With Application.InputBox("Select Range", "Select Cell to Apply Borders to", , , , , , 8)
        R1.Copy
        .PasteSpecial -4122
        .Resize(R1.Rows.Count, R1.Columns.Count).Style = "Normal"
    End With
         
    ActiveWorkbook.Styles("Normal").IncludeBorder = True
End Sub

---

@snb:
Thank you sir. It does not copy any formatting from the source range, except for the borders, it however changes existing formatting of the destination cells which it is not supposed to do.
Regards,
vanhunk

You are introducing a new requirement.

Quote:

---

Originally Posted by snb

You are introducing a new requirement.

---

I am sorry sir, I assumed "Copy only borders of a range to new range" meant just that and nothing else. Not copy borders and change the formatting of the destination range.

My bad.

Regards,
vanhunk