简体   繁体   中英

Excel VBA Code to merge similar adjacent cells

I'd like to merge identical adjacent cells within a column. Some online examples loop through the column and merge every time the cell below matches, and I'd like to avoid that. Here's my current broken attempt that spits out run-time error 5.

Sub Merge2()
    Application.ScreenUpdating = False
    
    Dim rng1 As Range
    Dim rng2 As Range
    Dim certaincell As Range
    
    Dim LastRow As Long
    LastRow = 0
    LastRow = Cells(Rows.Count, 35).End(xlUp).Row
    
    Set rng1 = Range(Cells(2, 35), Cells(LastRow, 35))
    
CheckUnder:
    For Each certaincell In rng1
        
        Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range
        
        If certaincell.Value = certaincell.Offset(1, 0).Value Then  'if the cell is the same as the cell under
            'move on to next cell
        
        Else
            rng2.Merge 'merge similar cells above
            Set rng2 = Nothing
            
        End If
        
    Next
    
    Application.ScreenUpdating = True
End Sub

The variable rng2 is initially set to Nothing. So, adjust your code as follows:

For Each certaincell In rng1     
   If rng2 Is Nothing Then
      Set rng2 = certaincell
   End If
   Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range     
   If certaincell.Value = certaincell.Offset(1, 0).Value Then
   Else
      rng2.Merge 'merge similar cells above
      Set rng2 = Nothing
   End If     
Next

The if statement will check if the rng2 is nothing and if so, it will assign the currently checked certaincell to the variable.
Also, merging cells with data will pop up some error dialogs. This can be avoided by using Application.DisplayAlerts = False .
Make sure to turn it on using Application.DisplayAlerts = True at the end.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM