Option Explicit
Sub CopyFromMergedAreaToMergedArea()
Range("K9").MergeArea.Copy Destination:=Range("V17").MergeArea
End Sub
Sub FindMergedCellsOnActiveSheet()
Dim oFound As Object
Dim sValue As String
Dim lLwkCount As Long
Dim lLWKIndex As Long
Dim lPos As Long
Dim lStartInstr As Long
Dim sFirstAddress As String
Dim sOutput As String
Dim lMergeCount As Long
Application.FindFormat.Clear
Application.FindFormat.MergeCells = True
With ActiveSheet.UsedRange
.Cells(1, 1).Select 'Otherwise an error if activecell is outside usedrange
On Error Resume Next 'Continue if no merged cells on activesheet
.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True).Activate
If Err.Number = 91 Then
MsgBox "No merged cells on worksheet " & ActiveSheet.Name, , "No Merged Cells"
GoTo End_Sub
End If
On Error GoTo 0
sFirstAddress = Selection.Address
Do
sOutput = sOutput & ", " & Selection.Address
lMergeCount = lMergeCount + 1
'Normally would use FindNext here, but it would not work with only formatting
.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True).Activate
Loop While Selection.Address <> sFirstAddress
sOutput = Mid(sOutput, 3)
MsgBox sOutput, , lMergeCount & " Merged Area" & IIf(lMergeCount > 1, "s", "")
End With
End_Sub:
End Sub