Option Explicit
Dim a,ssr,ssc,m,smr, smc, emr, emc
Test
'**********************************************************************************************************************
Sub Test()
 
 Dim oExcel, Rng
 MsgBox "111"
 Set oExcel = GetObject(, "Excel.Application")
 MsgBox "222"
 If Err.Number<>0 Then
  Err.Clear
  MsgBox "Error found"
  Set oExcel = CreateObject("Excel.Application")
 End If
 oExcel.Application.Visible = True
 oexcel.Parent.Windows(1).Visible = True
 Set Rng = oExcel.ActiveWindow.Selection
 MsgBox "The Selection Area is "&Rng.Address(0,0),,"Selection Area"
 Dim d, c ', m
 Dim sta   'Store the address of the first cell in the selection
 'Dim ssr   'Store the row number of the selection range,row of selection
 'Dim ssc   'Store the column number of the selection range,column of selection
 Dim i
 'Dim smr, smc, emr, emc
 
 sta = Rng.Cells(1, 1).Address(0, 0)
 ssc = Asc(Left(sta, 1)) - Asc("A") + 1
 ssr = CInt(Right(sta, Len(sta) - 1))
 
 Set d = CreateObject("scripting.dictionary")
 
 For Each c In Rng
  If c.MergeCells Then
   If Not d.exists(c.MergeArea.Address(0, 0)) Then
    m = m + 1
    d(c.MergeArea.Address(0, 0)) = ""
   End If
  End If
 Next
 
 If m > 0 Then
  'Dim a
  a = d.keys
  'smc = SMColumn(a, ssr, ssc, m)
  smc = SMColumn()
  'smr = SMRow(a, ssr, ssc, m)
  smr = SMRow()
  'emc = EMColumn(a, ssr, ssc, m)
  emc = EMColumn()
  'emr = EMRow(a, ssr, ssc, m)
  emr = EMRow()
  
  For i = 0 To m - 1
   MsgBox "Will be merged cells in the table is: (" & smr(i) & "," & smc(i) & ") " & "(" & emr(i) & "," & emc(i) & ") ",,"Merged Area"
  Next
 Else
  MsgBox "没有合并区域"
 End If
End Sub          
'**********************************************************************************************************************
'Function SMColumn(ByVal a, ByVal ssr, ByVal ssc, ByVal m) 'smc
Function SMColumn() 'smc
 Dim i
 Dim smc()  'Store the start column number of the merge area
 
 ReDim smc(m)
 For i = 0 To m - 1
  smc(i) = Asc(Left(a(i), 1)) - Asc("A") - ssc + 2
 Next
 SMColumn = smc
 
End Function
'**********************************************************************************************************************
'Function SMRow(ByVal a, ByVal ssr, ByVal ssc, ByVal m) 'smr
Function SMRow() 'smr 
 Dim i
 Dim smr()  'Store the start row number of the merge area
 
 ReDim smr(m)
 For i = 0 To m - 1
  smr(i) = CInt(Mid(a(i), 2, InStr(a(i), ":") - 2)) - ssr + 1
 Next
 SMRow = smr
 
End Function
'**********************************************************************************************************************
'Function EMRow(ByVal a, ByVal ssr, ByVal ssc, ByVal m) 'emr
Function EMRow() 'emr
 Dim i
 Dim emr()  'Store the start row number of the merge area
 
 ReDim emr(m)
 For i = 0 To m - 1
  emr(i) = CInt(Right(a(i), Len(a(i)) - InStr(a(i), ":") - 1)) - ssr + 1
 Next  
 EMRow = emr
 
End Function
'**********************************************************************************************************************
'Function EMColumn(ByVal a, ByVal ssr, ByVal ssc, ByVal m) 'emc
Function EMColumn() 'emc    
 Dim i
 Dim emc() 'Store the start row number of the merge area
 
 ReDim emc(m)
 For i = 0 To m - 1
  emc(i) = Asc(Mid(a(i), InStrRev(a(i), ":") + 1, 1)) - Asc("A") - ssc + 2
 Next       
 EMColumn = emc
 
End Function
复制代码