excel 合并指定列的相同单元格函数
Sub main()
合并相同项 "c", False
End Sub
'合并指定列的相同单元格
Function 合并相同项(ByVal colA As String, ByVal Sort As Boolean)
'colA  要合并的列
'Sort  是否索引
On Error Resume Next '设置错误处理
Application.ScreenUpdating = False '关闭屏幕刷新
Dim col As Integer
Dim maxRec As Integer
Dim maxCol As Integer
Dim stRw, enRw As Integermerge函数
Dim tmp As String
Dim i As Integer
maxRec = ActiveSheet.UsedRange.Rows.Count
maxCol = ActiveSheet.UsedRange.Columns.Count
colA = UCase(colA)
col = Asc(colA) - 64
If Not Range(colA & "2" & ":" & colA & maxRec).MergeCells Then '判断指定列是否有合并单元格
If Sort Then    '对要处理的列排序
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(colA & "2:" & colA & maxRec), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A2:" & Chr(maxCol + 64) & maxRec)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
stRw = 2
tmp = Cells(2, col)
For i = 2 To maxRec + 1
If tmp <> Cells(i, col) Then
tmp = Cells(i, col)
If enRw <= stRw Then
enRw = stRw
Else
Range(colA & stRw + 1 & ":" & colA & enRw).Clear
Range(colA & stRw & ":" & colA & enRw).Merge
Range(colA & stRw & ":" & colA & enRw).VerticalAlignment = xlCenter
End If
Debug.Print stRw, enRw
stRw = i
Else
enRw = i
End If
Next i
Else '列有合并单元格则提示
MsgBox "请先清除" & colA & "列中的合并单元格，并且将空白区域填充完整！" & vbCrLf & "否则程序不能正常工作！", vbInformation
End If
Application.ScreenUpdating = True '打开屏幕刷新
End Function

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。