Copy only borders of a range to new range

[vanhunk]

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

[Jan Karel Pieterse]

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

        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

[snb]

You might use:

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

[vanhunk]

@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

[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:

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:

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!

[snb]

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

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

[vanhunk]

@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

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

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

[vanhunk]

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

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

[snb]

It doesn't with:

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

[vanhunk]

@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

[snb]

You are introducing a new requirement.

[vanhunk]

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