Объединение ячеек

[ing60]

Добрый день! Подскажите, как объединить ячейки с повторяющимися одинак.значениями в одном столбце (им соответствуют различные значения в других столбцах). Т.е. неск. одинак. строк в первом столбце - объединить в 1 ячейку.

[EducatedFool]

как объединить ячейки с повторяющимися одинак.значениями в одном столбце

Например, вручную.

Если нужен макрос - будьте любезны выложить пример файла...

[ing60]

Значений в столбце несколько тысяч.

[EducatedFool]

Сообщение от ing60

Значений в столбце несколько тысяч.

Это следует понимать как нежелание объединять ячейки вручную?

Тогда подождите несколько дней - прежде чем написать макрос, мне понадобится время на подготовку тестового файла...

[Volodshan]

Сообщение от ing60

Добрый день! Подскажите, как объединить ячейки с повторяющимися одинак.значениями в одном столбце (им соответствуют различные значения в других столбцах)...

Лучше таблицу не ломать, а сделать сводную и далее работать с ней.

[VovaKl]

Маленький пример сравнения двух ячеек - текущей и что ниже при совпадении значения объединяет. По такому принципу можно создать поиск смежных диапазонов с одинаковыми значениями и затем объединять найденное. НО возникает два вопроса - как подавить навязчивое сообщение о потере данных в ячейках (я этого не знаю - не было надобности) и по какому событию или по какой команде запускать такую приблуду

Этот макрос необходимо скопировать на лист в редакторе VBA, реакция на двойной клик мыши:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error Resume Next
If Target.Item(1).Value = Target.Item(1).Offset(1, 0).Value Then Range(Target, Target.Offset(1, 0)).Merge
End If
End Sub

Без примера ничего другого предложить не могу.
Владимир

[VovaKl]

Виноват даже не посмотрел выложенная процедура с реакцией на выбор ячейки, это не совсем удобно, вот на двойной клик:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error Resume Next
If Target.Item(1).Value = Target.Item(1).Offset(1, 0).Value Then Range(Target, Target.Offset(1, 0)).Merge
End If
End Sub

[IgorGO]

Sub MergeCls()
  r1 = 1
  r2 = 1
  Do
    If Cells(r1, 1) <> Cells(r2 + 1, 1) Then
      If r1 <> r2 Then
        Range(Cells(r1 + 1, 1), Cells(r2, 1)).ClearContents
        Range(Cells(r1, 1), Cells(r2, 1)).MergeCells = True
      End If
      r1 = r2 + 1
    End If
    r2 = r2 + 1
  Loop Until Cells(r2, 1) = ""
End Sub

обьединит идущие подряд одинаковые ячейки в первом столбце. работает до первой пустой ячейки в первой колонке.
2 VovaKl:

как подавить навязчивое сообщение о потере данных в ячейках (я этого не знаю - не было надобности)

- очистить данные в обьединяемых ячейках кроме первой.

по какому событию или по какой команде запускать такую приблуду

- запуск вручную

[ing60]

Огромное спасибо всем за помощь!

[VovaKl]

Игорь, я прошу извинить меня, макрос понравился и я немножко подправил его для старта с активной ячейки:

Sub MergeCls()
Dim ri As Integer, r2 As Integer, Col As Integer
r1 = ActiveCell.Row
r2 = ActiveCell.Row
Col = ActiveCell.Column
Do
If Cells(r1, Col) <> Cells(r2 + 1, Col) Then
If r1 <> r2 Then
Range(Cells(r1 + 1, Col), Cells(r2, Col)).ClearContents
With Range(Cells(r1, Col), Cells(r2, Col))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
End If
r1 = r2 + 1
End If
r2 = r2 + 1
Loop Until Cells(r2, Col) = ""
End Sub