Copying the Merge-Formatting of a Table Using VBA - vba

Question

I'm trying to create a macro that works on columns that are adjacent to an existing table. The purpose of this macro is to take any cell merges that exist in the table and copy them into the next two columns (It's a helper method for something with a larger purpose). My code is below but I'm getting an error that says, "PasteSpecial method of Range class failed" which occurs on the line:
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
The line directly above was a test line to check if the code was working for the first iteration of the loop, which it is. Once the code tried to re-iterate and paste again, however, the code fails. I believe it's because the 'Selection.PasteSpecial' call is not referencing the correct object anymore but I'm not sure how to fix it.
Sub extendColumnMerges()
'
' Works on a column adjacent to a table by extending the column's merge-formatting to the selected column
' Active cell must begin as the first cell in the column immediatley adjacent the table on the right
'
Dim cols As Integer
cols = 2
'Selects the last column of the table and copies the selection into the new column, modifying the format of the new column
Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, -1).End(xlDown)).Select
Selection.Copy
'Pastes the columns' merge-formatting into each specified column adjacent the table on the right
For c = 1 To cols
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "Yes"
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Removes the formatting from the cells in the new column
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Removes borders from the newly modified column
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Select
Next c
End Sub
Also, if there are any suggestions as to how to code this in a more elegant manner they would be greatly appreciated. Copying the formatting and then removing the borders and fills seems bulky in code. Thanks.

Answer 1

This seemed to work for me:
Sub Tester()
'copy the merged areas of the current selection 4 columns to the right
ReplicateMergeAreas Selection, 4
End Sub
Sub ReplicateMergeAreas(sourceArea As Range, colOffset As Long)
Dim rw As Long, col As Long
Dim c As Range, c2 As Range
Dim rngTL As Range
'set the cell at the top-left of the "destination" range
' (actually offset -1,-1 to make it easier to set range 'c2')
Set rngTL = sourceArea.Cells(1).Offset(-1, colOffset - 1)
'loop through each cell in the "source" range
For rw = 1 To sourceArea.Rows.Count
For col = 1 To sourceArea.Columns.Count
'c=cell in source range
Set c = sourceArea.Cells(rw, col)
'is this cell merged?
If c.MergeArea.Cells.Count > 1 Then
'c2=corresponding cell in the destination range
Set c2 = rngTL.Offset(rw, col)
'Is the "destination" cell already merged?
' skip if yes
If c2.MergeArea.Cells.Count = 1 Then
'set merge area the same size as the "source" cell
c2.Resize(c.MergeArea.Rows.Count, _
c.MergeArea.Columns.Count).Merge
End If
End If
Next col
Next rw
End Sub
The range passed to the sub must be a single-area rectangular range which completely encloses all the merged areas (or at least their top-left corners) you want to replicate across. colOffset is how many columns over you want to copy the merging to.