PDA

View Full Version : [SOLVED] Copy only borders of a range to new range



vanhunk
11-25-2014, 05:07 AM
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
11-25-2014, 05:59 AM
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
11-25-2014, 08:19 AM
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
11-26-2014, 12:52 AM
@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
11-26-2014, 02:50 AM
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
11-26-2014, 09:21 AM
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
11-26-2014, 11:40 PM
@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
11-26-2014, 11:43 PM
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
11-27-2014, 03:01 AM
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
11-27-2014, 11:56 PM
@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
11-28-2014, 03:21 AM
You are introducing a new requirement.

vanhunk
12-01-2014, 12:04 AM
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