Excel Visual Basic Macro для объединения ячеек в выделенной области

Question

У меня есть таблица Excel, в которой я хочу объединить каждую ячейку со значением в ней с каждой пустой ячейкой под ней до следующей ячейки в этом столбце со значением.

В настоящее время у меня есть это:

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 

Который работает на весь лист, но я хочу макрос применить только к выбранной области. Однако простое изменение For col = 1 to 50 на For Each cell In Selection делает макрос, казалось бы, ничего не делая.

Пример данных:

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

Где --- показывает ячейка пуста.

Answer 1

Вот приблизительный способ слияния вашего выбора по вашему желанию. Обратите внимание, что это не будет работать так, как вы собираетесь, если это не значение в первой ячейке

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

достаньте «On Error Resume Next», что это верный способ, чтобы скрыть какие-либо ошибки ..

Answer 3

Я считаю, что ваша проблема в том, что переменные не были объявлены, так VBA делает догадку на то, что они , Используйте этот код и посмотреть, если вы получаете какие-либо ошибки:

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 

Единственная ошибка, которую он может бросить, ошибка после того, как там больше нет SpecialCells(xlCellTypeBLanks), что означает, что он успешно провел по всем ячейкам.

Answer 4

я буду считать, что вы не хотите, чтобы когда-либо объединить вторую строку со строкой заголовка.

После выделения строки 3 до последней использованной строки в блоке данных излучающего из А1 с Range.CurrentRegion property и Range.Resize/Range.Offset свойствами, использует Range.SpecialCells method с xlCellTypeBlanks. По мере прохождения через Range.Areas property, изменение размера и смещение перед слиянием.

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