在不循环Excel的情况下合并重复单元格的最快方法 [英] fastest way to merge duplicate cells in without looping Excel
问题描述
我的单元格包含要快速合并的重复值.该表如下所示:
I have cells containing duplicate values that i want to merge quickly. The table looks like this:
Sub MergeCells()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant
ReDim arr(1 To 1) As Variant
With ThisWorkbook.Sheets("tst")
Set Rng = .Range("A2:D11")
lRow = Rng.End(xlDown).Row
For J = 1 To 4
For I = lRow To 2 Step -1 'last row to 2nd row
If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then
Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
arr(UBound(arr)) = R.Address
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
Next I
Next J
ReDim Preserve arr(1 To UBound(arr) - 1)
Set R = .Range(Join(arr, ","))
'MsgBox R.Areas.Count
'R.Select
'R.MergeCells = True
With R
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Stop
End With
Application.DisplayAlerts = True
End Sub
重复的单元格范围可以是不相交的单元格或不相邻的单元格.我想要一种无需使用For循环即可快速识别此类重复范围并合并它们的方法. [不知道,但是认为有一种最快的创新方法,可以不使用循环,而可以使用Excel数组公式和VBA代码的某种组合来选择和合并重复的单元格范围.]
The duplicate cells ranges could be disjointed or non-adjacent cells. I want a way to quickly identify such duplicate ranges and merge them without using a For loop. [Don't know, but think there could be a fastest innovative way without loops probably using some combination of Excel array formulae and VBA code, to select and merge duplicate cell ranges.]
顺便说一句,上面的代码可以正常工作,直到它在行 .Merge 出现以下错误为止.
BTW the above code works fine till it shoots up the following error at line .Merge.
编辑 这是监视"窗口的快照,其中显示了 arr 内容以及 R.Address .
EDIT This is a snapshot of the Watch window showing the arr content as well as R.Address.
输出: 不需要任何选择,这只是出于演示目的:
OUTPUT: Don't need any selections, this is just for demonstration purpose:
输出应如下所示:
编辑... 假设各行中的重复值相同?因此,只有重复的列值才能合并.必须有一种快速,创新的方式来进行合并.
EDIT... Suppose the duplicate values were same across the rows? So only duplicate columns values to be merged. There has to be an quick, innovative way to do this merge.
最终输出图像:
推荐答案
问题是您的代码只能找到2个相邻的单元,而没有使用该代码寻找第三个单元:Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
The issue is that your code can only find 2 adjacent cells and is not looking for a third one with this code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
在第一个循环之后,它添加了这2个单元格
After the first loop it adds these 2 cells
在另一个循环之后,它添加了接下来的2个单元格
After another loop it adds the next 2 cells
这导致重叠
您可以在所选内容的深色阴影处看到它.
And this results in an overlapping
which you can see at the darker shading of the selection.
我刚刚用注释编辑了部分代码,因此您可以看到它是如何完成的.但我确信仍有改进的空间.
I just edited some part of your code with comments, so you can see how it could be done. But I'm sure there is still space for improvements.
Sub MergeCellsNew()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant
ReDim arr(1 To 1) As Variant
With ThisWorkbook.Sheets("tst")
Set Rng = .Range("A2:D11")
lRow = Rng.End(xlDown).Row
For J = 1 To 4
I = 2 'I = Rng.Row to automatically start at the first row of Rng
Do While I <= lRow
Set R = .Cells(I, J) 'remember start cell
'run this loop as long as duplicates found next to the start cell
Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
I = I + 1
Loop
'now if R is bigger than one cell there are duplicates we want to add to the arr
'this way single cells are not added to the arr
If R.Rows.Count > 1 Then
arr(UBound(arr)) = R.Address
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
I = I + 1
Loop
Next J
ReDim Preserve arr(1 To UBound(arr) - 1)
Set R = .Range(Join(arr, ","))
With R
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Stop
End With
Application.DisplayAlerts = True
End Sub
这篇关于在不循环Excel的情况下合并重复单元格的最快方法的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!