[英]Merge cells when cell value match (different column row value)
I would like to write a Excel vba to merge cells according to their values and a reference cell in another column.我想编写一个 Excel vba 来根据单元格的值和另一列中的引用单元格合并单元格。 Like the picture attached.就像附图一样。 I have over 18000 Lines, with many of variation.我有超过 18000 行,有很多变化。 All the values within the line are in order rank.该行内的所有值均按顺序排列。
enter image description here在此处输入图片说明
This is the code that I based my VBA这是我基于 VBA 的代码
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Edit Minor upgrade to allow merged ranges to be extended enabling merge updates.编辑次要升级以允许扩展合并范围以启用合并更新。
Const
) come before any other code in the module.确保常量 ( Const
) 出现在模块中的任何其他代码之前。Copy/Paste复制粘贴
Private Const LastCol = 20
Private Const LastRow = 20
Public Sub Merge_Cells()
Dim r As Range
Dim s As Range
Dim l As Range
Dim c As Long
Dim v As Variant
For c = 1 To LastCol
Set s = Nothing
Set l = Nothing
For Each r In Range(Cells(1, c), Cells(LastRow, c))
v = r.MergeArea(1, 1).Value
If v = vbNullString Then
DoMerge s, l
Set s = Nothing
Set l = Nothing
ElseIf s Is Nothing Then
Set s = r
ElseIf s.Value <> v Then
DoMerge s, l
Set s = r
Set l = Nothing
Else
Set l = r
End If
Next r
DoMerge s, l
Next c
End Sub
Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
If s Is Nothing Then Exit Sub
If l Is Nothing Then Set l = s
Application.DisplayAlerts = False
With Range(s, l)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge
End With
Application.DisplayAlerts = True
End Sub
Consider finding the last column and last row programmatically.考虑以编程方式查找最后一列和最后一行。
If the merge should start after row 1:如果合并应该在第 1 行之后开始:
For Each r In Range(Cells(1, c), Cells(LastRow, c))
^
1
to the correct row number or replace with an added const
variable.将1
更改为正确的行号或替换为添加的const
变量。To guard other worksheets, use the tab name (recommend renaming the tab first):要保护其他工作表,请使用选项卡名称(建议先重命名选项卡):
For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
^^^^^^^^^^^^^^^^^^^^
Private Const TabName = "The Merge Tabs Name" ' Spaces ok
并添加Private Const TabName = "The Merge Tabs Name" ' Spaces ok
Const
(constants) .到模块的顶部与其他Const
(constants) 。Worksheets("The Merge Tabs Name")
.或者将名称直接放在代码中: Worksheets("The Merge Tabs Name")
。Add this into a module, select your range of data (excluding headers), run the macro and see if it works for you.将此添加到模块中,选择您的数据范围(不包括标题),运行宏并查看它是否适合您。
Public Sub MergeRange()
Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
Dim strBottomCell As String, strThisValue As String, strNextValue As String
Dim strThisMergeArea As String, strNextMergeArea As String
Set rngData = Selection
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With rngData
For lngCol = 1 To .Columns.Count
strTopCell = ""
For lngRow = 1 To .Rows.Count
If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address
strThisValue = .Cells(lngRow, lngCol)
strNextValue = .Cells(lngRow + 1, lngCol)
If lngCol > 1 Then
strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
strNextMergeArea = .Cells(lngRow + 1, lngCol - 1).MergeArea.Address
If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue & "."
End If
If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
strBottomCell = .Cells(lngRow, lngCol).Address
With rngData.Worksheet.Range(strTopCell & ":" & strBottomCell)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
strTopCell = .Cells(lngRow + 1, lngCol).Address
End If
Next
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There's one trick to this which is able to be changed and that is that it will also group based off the prior column.对此有一个技巧可以更改,那就是它也将根据前一列进行分组。 You can see an example of what I'm talking about in cell C19 ...您可以在单元格 C19 中看到我正在谈论的内容的示例...
... it has worked out that the previous column had a grouping that stopped at that point, therefore, the 1 isn't carried through and grouped to the next lot, it stops and is grouped there. ... 已经计算出前一列有一个在该点停止的分组,因此,1 没有通过并分组到下一个批次,它停止并在那里分组。 I hope that makes sense and I hope it gives you what you need.我希望这是有道理的,我希望它能给你你所需要的。
Another thing, this code here will attempt to demerge all of your previously merged data.另一件事,这里的代码将尝试分离您之前合并的所有数据。
Public Sub DeMergeRange()
Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
Dim strLastCell As String, objDestRange As Range
Set rngData = Selection
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With rngData
For lngCol = 1 To .Columns.Count
For lngRow = 1 To .Rows.Count
Set objCell = .Cells(lngRow, lngCol)
If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
strMergeRange = objCell.Areas(1).MergeArea.Address
objCell.MergeCells = False
strFirstCell = Split(strMergeRange, ":")(0)
strLastCell = Split(strMergeRange, ":")(1)
Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address & ":" & strLastCell)
.Worksheet.Range(strFirstCell).Copy objDestRange
End If
Next
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
A note, my suggestion is to ensure you have the original source data saved to another workbook/sheet as a backup before running any code over the top of it.注意,我的建议是确保在运行任何代码之前将原始源数据保存到另一个工作簿/工作表作为备份。 If it stuffs with your data then it will be a right royal pain to undo manually.如果它塞满了您的数据,那么手动撤消将是一种正确的皇家痛苦。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.