Страницы: 1
RSS
Объединить ячейки с одинаковым содержимым (учитывать, объединены ли соседние ячейки) с суммированием
 
Название темы:
Объединение ячеек с одинаковым содержимым, при этом учитывать, объединены ли соседние ячейки, а так же суммирование объединенных ячеек с числовыми значениями.

Доброго времени суток.
Есть исходная таблица.

Исходная.xlsx (8.98 КБ)
Есть макрос, который объединяет ячейки с одинаковыми значениями:
Код
Sub JoinDoubles()
Dim i As Long
Application.DisplayAlerts = False
For i = Selection.Rows.Count To 2 Step -1
  If Selection.Cells(i, 1) = Selection.Cells(i - 1, 1) Then
  Range(Selection.Cells(i - 1, 1), Selection.Cells(i, 1)).Merge
  End If
Next
Selection.VerticalAlignment = xlVAlignCenter
Application.DisplayAlerts = True
End Sub

Но при работе макроса, получается так, что он не учитывает соседние ячейки, а обрабатывает только один столбец, и получается не корректное объединение ячеек:

Работа макроса не корректна.xlsx (9.22 КБ)

В идеале, хотелось бы получить такой результат, чтобы при объединении ячеек учитывалось состояние объединённых ячеек слева, а так же, если ячейки содержат цифры, то в объединённой ячейке выводилась бы сумма.

В идеале.xlsx (9.15 КБ)

Заранее всем спасибо)
 
Было бы замечательно.
 
Код
Sub JoinDoubles()
Dim i As Long
Application.DisplayAlerts = False
For i = Selection.Rows.Count To 2 Step -1
  If Selection.Cells(i, 1) = Selection.Cells(i - 1, 1) Then
  Range(Selection.Cells(i - 1, 1), Selection.Cells(i, 1)).Merge
  End If
Next
Dim s As Long
For i = Selection.Rows.Count To 2 Step -1
  If Selection.Cells(i, 2) = Selection.Cells(i - 1, 2) Then
    If Selection.Cells(i, 1).MergeArea.Address = Selection.Cells(i - 1, 1).MergeArea.Address Then
        s = WorksheetFunction.Sum(Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)))
        Range(Selection.Cells(i - 1, 2), Selection.Cells(i, 2)).Merge
        Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)).Merge
        Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)).Value = s
    End If
  End If
Next
Selection.VerticalAlignment = xlVAlignCenter
Application.DisplayAlerts = True
End Sub
 
Такой вариант будет быстрее работать. Разница будет заметна при большом количестве строк.
Код
Sub JoinDoubles()
Application.DisplayAlerts = False
Dim iApplication_Calculation As Long
iApplication_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim i As Long
Dim a As Variant
a = Selection
For i = UBound(a, 1) To 2 Step -1
  If a(i, 1) = a(i - 1, 1) Then
  Range(Selection.Cells(i - 1, 1), Selection.Cells(i, 1)).Merge
  End If
Next
Dim s As Long
For i = UBound(a, 1) To 2 Step -1
  If a(i, 2) = a(i - 1, 2) Then
    If Selection.Cells(i, 1).MergeArea.Address = Selection.Cells(i - 1, 1).MergeArea.Address Then
        s = WorksheetFunction.Sum(Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)))
        Range(Selection.Cells(i - 1, 2), Selection.Cells(i, 2)).Merge
        Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)).Merge
        Range(Selection.Cells(i - 1, 3), Selection.Cells(i, 3)).Value = s
    End If
  End If
Next
Selection.VerticalAlignment = xlVAlignCenter
Application.Calculation = iApplication_Calculation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
МатросНаЗебре, спасибо Вам ОГРОМНОЕ!!!!
Всё работает отлично.

От супруги отдельная благодарность!!!
 
Цитата
МатросНаЗебре написал:
Такой вариант будет быстрее работать. Разница будет заметна при большом количестве строк.
Помогите пожалуйста исправить макрос так, чтобы он ещё объединял ячейки в столбце D (ячейки пустые), ориентируясь на ячейки из столбца С. Если C1 и С2 объединены, то и D1 и D2 тоже объединит.
Сейчас так:


Нужно так:


Заранее спасибо за помощь!
Изменено: Павел Лебедев - 25.02.2021 12:50:59
 
Здравствуйте, пробую запустить макросы с этой темы и выпадает ошибка VBA:
---------------------------
Run-time error '13':

Type mismatch
---------------------------
ОК   Справка  
---------------------------

Что у меня не так для его работы? excel 2019, файл в xlsm пересохранил....
Изменено: mar1boro - 17.09.2024 14:48:57
 
Цитата
mar1boro написал:
Что у меня не так для его работы? excel 2019, файл в xlsm пересохранил....
Файл покажите. Без него ответить невозможно. Конфиденциальную информацию замените на яблоки-груши. если файл очень большой - урежьте его так, чтобы ошибка сохранялась.
 
Хотя бы строку кода, в которой возникает ошибка, покажите. Но лучше конечно смотреть файл
Согласие есть продукт при полном непротивлении сторон
 
Вот файл. Это я взял первый файл и первого поста этой темы и вставил код из поста #4.  
 
А если код меняю на код из поста #3, то ошибки нет, но и после выполнения в этом файле ничего не меняется.
 
Все у Вас работает. Нужно ВЫДЕЛИТЬ диапазон и запустить макрос
Согласие есть продукт при полном непротивлении сторон
 
Sanja, извините, не догадался про выделение диапазона. А можно что-то добавить, чтобы автоматически диапазон определялся?  
 
Можно
Скрытый текст

И этот код лучше хранить в обычном модуле, а не в модуле листа
Согласие есть продукт при полном непротивлении сторон
 
все же у меня чуть другая задача. помогите, пожалуйста. Нужно , чтобы по коду товара объединялись строки с суммированием количества , при этом код товара чтобы не участвовал в вычислениях.

 
Тогда Сводная таблица будет Вам в самый раз
Создание отчетов при помощи сводных таблиц
Изменено: Sanja - 17.09.2024 15:48:31
Согласие есть продукт при полном непротивлении сторон
 
Sanja, это мегакрутая штука, работает! спасибо. Форумы живы!
 
mar1boro, Измените отображаемое имя, сейчас оно с нарушением Правил форума
Цитата
3. Запрещено

  3.2. Использовать в сообщениях, подписях и логинах на форумах нецензурную лексику, текст с пЕреМеНнЫм регистром или бессмысленным набором символов, заменять буквы другими символами.
Согласие есть продукт при полном непротивлении сторон
 
Sanja, ок
Страницы: 1
Читают тему
Наверх