我想编写一个Excel vba来根据单元格的值合并单元格并在另一列中引用单元格。就像所附的图片。 我有18000多行,有很多变化。 该行中的所有值均按顺序排列。
这是我基于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
答案 0 :(得分:0)
编辑较小升级,可以扩展合并范围,从而启用合并更新。
Const
)在模块中的任何其他代码之前。复制/粘贴
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
考虑以编程方式查找最后一列和最后一行。
如果合并应该在第1行之后开始
For Each r In Range(Cells(1, c), Cells(LastRow, c))
^
1
更改为正确的行号,或替换为添加的const
变量。 要保护其他工作表,请使用标签名称(建议先重命名该标签):
For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
^^^^^^^^^^^^^^^^^^^^
Private Const TabName = "The Merge Tabs Name" ' Spaces ok
Const
(常量) 移到模块顶部。Worksheets("The Merge Tabs Name")
。答案 1 :(得分:0)
将其添加到模块中,选择数据范围(不包括标头),运行宏,然后查看它是否对您有用。
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
对此有一个技巧可以更改,那就是它还将根据前一列进行分组。您可以在单元格C19中看到我正在谈论的示例...
...已经计算出,上一列的分组在该点处停止,因此,不会继续进行1分组并将其分组到下一个批次,它将停止并在此处分组。我希望这是有道理的,希望它能为您提供所需的东西。
另一件事,此代码将尝试合并所有以前合并的数据。
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
请注意,我的建议是在运行任何代码之前,确保将原始源数据作为备份保存到另一个工作簿/工作表中。 如果其中包含您的数据,那么手动撤消将是一件很痛苦的事情。