Excel Visual Basic宏合并选定区域中的单元格

Question

I have an excel spreadsheet where I want to merge each cell with a value in it with every empty cell below it until the next cell in that column with a value.

Currently I have this:

Sub mergemainbody()    
    lrow = ActiveSheet.UsedRange.Rows.Count - 2        
    On Error Resume Next  
    Application.DisplayAlerts = False  
    For col = 1 To 50  
       For Each ar In Cells(3, col).Resize(lrow).SpecialCells  (xlCellTypeBlanks).Areas  
          ar.Resize(ar.Rows.Count + 1).Offset(-1).Merge  
       Next  
    Next  
 End Sub

Which works on an entire sheet, but I want the macro to only apply to a selected area. However, simply changing For col = 1 to 50 to For Each cell In Selection makes the macro seemingly do nothing.

Example of data:

Heading | Heading   | Heading   | Heading   |      
1456262 | 270520    | 574038    | 583059    |    
Words   | --------- | --------- | --------- |  
586048  | --------- | --------- | --------- |        
Words   | 694574    | 856738    | 068438    |    

Where --- shows the cell is empty.

Answer 1

Here is a rough way to merge down on your selection as you requested. Note that this won't work the way you intend if there isn't a value in the first cell

Sub MergeDown()
    Dim rng As Range, r As Range
    Dim i As Integer

    Set rng = Selection
    For Each r In rng
        If r.Value <> "" Then
            i = 1
            While r.Offset(i, 0).Value = "" And Not Intersect(r.Offset(i, 0), rng) Is Nothing
                i = i + 1
            Wend
            r.Resize(i, 1).Merge
        End If
    Next r
End Sub

Answer 2

I will assume that you do not want to ever merge the second row with the header row.

After isolating row 3 to the last used row in the data block radiating out from A1 with the Range.CurrentRegion property and the Range.Resize / Range.Offset properties, use the Range.SpecialCells method with xlCellTypeBlanks . As you cycle through the Range.Areas property , resize and offset before merging.

Dim c As Long, a As Long
With ActiveSheet
    'work on the block of data radiating out from A1
    With .Cells(1, 1).CurrentRegion
        'move off the header row and first row of data
        With .Resize(.Rows.Count - 2, .Columns.Count).Offset(2, 0)
            'work through the columns
            For c = 1 To .Columns.Count
                'locate the blank cells in groups (aka Areas)
                With .Columns(c).Cells.SpecialCells(xlCellTypeBlanks)
                    'cycle through the areas (blank cell groups)
                    For a = 1 To .Areas.Count
                        'work with each Area in turn
                        With .Areas(a).Cells
                            'resize one row larger and offset one row up
                            .Resize(.Rows.Count + 1, 1).Offset(-1, 0).Merge
                            'optionally center the value in the newly merged cells
                            .VerticalAlignment = xlCenter
                        End With
                    Next a
                End With
            Next c
        End With
    End With
End With

Answer 3

I believe your problem is that the Variables were never declared, so VBA is making a guess at what they are. Use this code and see if you get any errors:

Option Explicit
Sub mergemainbody()
Dim selRange As Range
Dim lRow    As Long
Dim ar As Range, col As Range

Set selRange = Selection
lRow = selRange.Rows.Count - 2    ' Why -2?
'On Error Resume Next
Application.DisplayAlerts = False

For Each col In selRange.Columns
    For Each ar In Cells(3, col.Column).Resize(lRow).SpecialCells(xlCellTypeBlanks).Areas
        ar.Resize(ar.Rows.Count + 1).Offset(-1).Merge
    Next
Next col
End Sub

The only error that it may throw, is an error after there are no more SpecialCells(xlCellTypeBLanks) , which means it ran successfully over all cells.

Answer 4

拿出“ On Error Resume Next”，这是隐藏任何错误的肯定方法。