excel - 如何垂直和水平合并或合并具有相同值的单元格,Excel VBA?
问题描述
我在相邻单元格中有相同数据的工作表,我可以合并列 A 上的相同单元格。现在我需要合并或合并列 A 上合并单元格旁边的相邻相同单元格,这意味着如果 A2:A3 相同,则将被合并并随后合并 B2:B3 ,C2:C3, D2:D3 直到 L 列。
更新:除 Merge 之外的任何方法也都很好
工作表的此链接 https://easyupload.io/eew87p
Sub Merge_Similar_Cells()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ws As Worksheet
Dim WorkRng As Range
Set ws = ActiveSheet
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
Set WorkRng = ws.Range("A2:A" & LastRow)
CheckAgain:
For Each cell In WorkRng
If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(1, 0)).Merge
cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
解决方案
请测试下一个代码:
Sub Merge_Similar_Cells()
Dim LastRow As Long, ws As Worksheet, arrWork, i As Long, j As Long, k As Long
Set ws = ActiveSheet
If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
End If
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'determine how many consecutive similar rows exist:_________
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '____________________________________________________
For j = 1 To 12
ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
Next j
ws.Range(ws.Cells(i, 1), ws.Cells(i + k, 12)).VerticalAlignment = xlCenter 'apply vertical alignment for all obtained merged row
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
End If
Next i
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
编辑:
请尝试下一个代码,它不会合并相同列上的相似行。它删除相似的行,只保留一个并将单元格值附加在“M:P”范围内,由分隔vbLf
(放置在同一单元格中的单独行上):
Sub DeleteSimilarRows_AppendLastColuns()
Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
Dim strVal As String, m As Long, boolNoFilter As Boolean
Set ws = ActiveSheet
If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: boolNoFilter = True
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
End If
If Not boolNoFilter Then LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'determine how many consecutive similar rows exist:______
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '_________________________________________
For j = 13 To 16 'build the concatenated string of cells in range "M:P":
strVal = ws.Cells(i, j).Value
For m = 1 To k
strVal = strVal & vbLf & ws.Cells(i + m, j).Value
Next m
ws.Cells(i, j).Value = strVal: strVal = ""
Next j
For m = 1 To k 'place the cells for rows to be deleted in a Union range, to delete at the end, at once
If rngDel Is Nothing Then
Set rngDel = ws.Range("A" & i + m)
Else
Set rngDel = Union(rngDel, ws.Range("A" & i + m))
End If
Next m
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete 'delete the not necessary rows
ws.UsedRange.EntireRow.AutoFit: ws.UsedRange.EntireColumn.AutoFit
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
推荐阅读
- c - 将不同大小的纹理附加到 FBO 的问题
- windows - windows任务调度程序的问题
- ios - 隐藏 IOS 键盘
- python - Python Pandas Dataframe-将索引设置为具有自定义月份的日期时间
- ruby-on-rails - rails 5.0.7 中“image”的未定义方法 `[]':Sass::Script::Value::String
- asp.net-core - HTTP 错误 502.5 - ASP.NET Core 2.1 应用程序中的进程失败
- c++ - 按值从向量中查找和替换元素
- java - 从 Java 运行 plink 版本的 PuTTY
- python - 使用 2 级嵌套数组将数据帧转换为 JSON
- android-recyclerview - RecyclerView 里面 RecyclerView 里面 RecyclerView