[英]VBA Merging Columns in Excel
I am trying to write a simple thing that will merge cells in excel with the same information. 我正在尝试写一个简单的东西,它将合并具有相同信息的excel中的单元格。 What I've got thus far is what follows: 到目前为止,我得到的是以下内容:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
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 = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
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 = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. 因此,我遇到的问题分为两个问题,首先,我试图使它适用于A-AK列,但是正如您在上面看到的那样,我不知道如何将其组合而不只是使其重复相同事情超过30次。 Is there another way to group it. 还有另一种方式将其分组。
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. 同样,当我将范围分配给Range(“ AF2:AF1000”)和Range(“ AG2:AG1000”)时,Excel整体崩溃。 I was hoping you all could help steer me into the right direction. 我希望大家能帮助我指引正确的方向。
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method. 在子例程中重复执行代码表明某些例程功能应提取到其自己的方法中。
1000 seems like an arbitrary row: Range("B2:B1000")
. 1000似乎是任意行: Range("B2:B1000")
。 This range should be trimmed to fit the data. 应调整此范围以适合数据。
It is better to Union all the cells to be merged and merge them in a single operation. 最好合并所有要合并的单元格并在单个操作中合并它们。
Application.DisplayAlerts
does not need to be set to True. Application.DisplayAlerts
不需要设置为True。 It will reset after the subroutine has ended. 子程序结束后它将复位。
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. 在重新使用它之前,您一直在修改rngMerge中的单元格,但没有修改它的定义。 This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows. 如果您从底部开始并逐步进行,这可能会更好,因为情况类似于插入或删除行。
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array. 我添加了一个包装循环,该循环循环从数组中拉出多个列。
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). 我还注意到了子过程的“私有”性质,并且我猜这在工作表的私有代码表中(右键单击“名称”选项卡,“查看代码”)。 If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells. 如果代码要在多个工作表上运行,则它属于公共模块代码表(在VBE中使用“插入”,“模块”),并且应在单元格中添加适当的父工作表引用。
It appears you are running the same procedure on rngMerge
and rngMerge2
, and that they are the same size. 看来您在rngMerge
和rngMerge2
上运行相同的过程,并且它们的大小相同。
I suggest the following, where you just iterate through the columns, and then through the cells in each column: 我建议以下内容,您只需遍历各列,然后遍历各列中的单元格即可:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. 注意按照书面规定,这将仅处理重复项。 If you have triplets or more, only pairs of two will be combined. 如果您有三胞胎或三胞胎以上,则将只有两对组合。
I would frame the problem a bit differently. 我对问题的框架会有所不同。 Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. 您的代码将遍历范围内的每个单元格,将其与下一个单元格进行比较,如果两个值相等,则将它们合并在一起。 I think it a bit clearer to check each cell against the previous cell value instead. 我认为将每个单元格与先前的单元格值进行比较会更加清楚。
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers). 另外,您可以遍历各列,以避免代码重复(如其他答案中所述)。
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub
procedure: 如果要在多个范围上运行此代码,可以将在一个范围内执行合并的代码隔离到其自己的Sub
过程中:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure: 并从您的主过程中多次调用它:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References: 参考文献:
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.