我想创建一个列是否有重复值的宏,然后如果发现合并这些行。
我一直在使用一个循环来检查每个细胞和cell.Offset(1,0)
尝试,如果他们是平等的,将它们合并。然后格式化从该列复制到相邻的列。
我只是想合并一列(E),但问题是它一次只能检查两个单元,因此它不合并相同的值5。如果最后一行合并它也搅乱。一旦检查栏被合并,我只是要复制格式到邻近的相应列。
Sub Merge()
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
For Each cell In Range("E1:E" & lastRow)
If cell.Offset(1, 0).Value = cell.Value Then
Range(cell, cell.Offset(1, 0)).Merge
End If
Next cell
End Sub
此代码检查每个行的单元格和合并单元格垂直,如果他们有相同的值(也具有相同的结果值口诀!):
Sub MergeCellsVertically()
Dim ws As Worksheet
Dim currentRng As Range
Dim usedRows As Long, usedColumns As Long
Dim currentRow As Long, currentColumn As Long
Set ws = ActiveSheet
usedRows = ws.Cells.Find(What:="*", After:=ws.Cells(1), LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
usedColumns = ws.Cells.Find(What:="*", After:=ws.Cells(1), LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Application.DisplayAlerts = False
For currentColumn = 1 To usedColumns
For currentRow = usedRows To 2 Step -1
Set currentRng = ws.Cells(currentRow, currentColumn)
If currentRng.Value <> "" Then
If currentRng.Value = currentRng.Offset(-1, 0).Value Then
currentRng.Offset(-1, 0).Resize(2, 1).Merge
End If
End If
Next currentRow
Next currentColumn
Application.DisplayAlerts = True
Set currentRng = Nothing
Set ws = Nothing
End Sub
当你的例子显示了非均匀结构,这可能是一个很好的解决方案。如果你只是想通过一排,相邻细胞合并这,记住,只有合并区域的左上角单元格的内容“生存”来决定。
如果你想解决一个合并区域的内容,然后currentRng.MergeArea.Cells(1)
始终表示合并后的地区,这里的内容是第一个单元格。
Sub UnmergeCells()
Dim ws As Worksheet
Dim usedRows As Long, usedColumns As Long
Dim currentRng As Range, tempRng As Range
Dim currentRow As Long, currentColumn As Long
Set ws = ActiveSheet
usedRows = ws.UsedRange.Cells(1).Row + ws.UsedRange.Rows.Count - 1
usedColumns = ws.UsedRange.Cells(1).Column + ws.UsedRange.Columns.Count - 1
For currentRow = 1 To usedRows
For currentColumn = 1 To usedColumns
Set currentRng = ws.Cells(currentRow, currentColumn)
If currentRng.MergeCells Then
Set tempRng = currentRng.MergeArea
currentRng.MergeArea.UnMerge
currentRng.Copy tempRng
End If
Next currentColumn
Next currentRow
Set tempRng = Nothing
Set currentRng = Nothing
Set ws = Nothing
End Sub
由于Find
功能是在寻找在合并单元格上次使用的列或行坏了,我用的是标准UsedRange
代替。要知道,未合并(复制)的公式可能出现意外。