Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 24.03.2019, 04:25   #1
Haney
Новичок
Джуниор
 
Регистрация: 24.03.2019
Сообщений: 3
По умолчанию Макрос объединения ячеек с одинаковыми данными с условием

Добрый день!
Помогите пожалуйста с макросом. Есть несколько перевозок которые попадаются на одно время. Надо объединить перевозки дату относительно перевозке. Файл во вложении. Желательно чтоб это объединение было фиксировано на 2 столбца но с возможностью выбора диапазона выделением. Нашла макрос с такой возможностью, но он просто объединяет все похожие ячейки.

Sub MergeSameCell()
'Updateby20131127
Dim Rng As Range, xCell As Range
Dim xRows As Integer
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Вложения
Тип файла: xlsx Книга1.xlsx (12.2 Кб, 19 просмотров)

Последний раз редактировалось Haney; 24.03.2019 в 04:29.
Haney вне форума Ответить с цитированием
Старый 24.03.2019, 18:49   #2
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Такой вариант не годится? Код UDF есть где-то на форуме.
Вложения
Тип файла: xlsx Книга1 (16).xlsx (14.4 Кб, 17 просмотров)
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 24.03.2019, 19:47   #3
Haney
Новичок
Джуниор
 
Регистрация: 24.03.2019
Сообщений: 3
По умолчанию

К сожалению нет. В одной перевозке больше 1й накладной может быть. И у каждой накладной должна быть своя строчка
Haney вне форума Ответить с цитированием
Старый 24.03.2019, 22:40   #4
Казанский
Старожил
 
Аватар для Казанский
 
Регистрация: 31.12.2010
Сообщений: 2,133
По умолчанию

Пробуйте, работает с произвольным числом столбцов
Код:
Sub MergeSameCell()
Const xTitleId = "Programmersforum.ru"
Dim Rng As Range, xRows As Long, i&, j&, k&
  Set Rng = Application.Selection
  Set Rng = Application.InputBox("Range", xTitleId, Rng.Address, Type:=8)
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  xRows = Rng.Rows.Count + 1
  For i = 1 To xRows - 1
    For j = i + 1 To xRows
      For k = 1 To Rng.Columns.Count
        If Rng.Cells(i, k).Value <> Rng.Cells(j, k).Value Then GoTo 1
      Next
    Next
    GoTo 2
1   If j - i > 1 Then
      For k = 1 To Rng.Columns.Count
        Range(Rng.Cells(i, k), Rng.Cells(j - 1, k)).Merge
      Next
      i = j - 1
    End If
2 Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
exceleved@yandex.ru Яндекс.Деньги: 410011500007619
Казанский вне форума Ответить с цитированием
Старый 25.03.2019, 00:23   #5
Haney
Новичок
Джуниор
 
Регистрация: 24.03.2019
Сообщений: 3
По умолчанию

Цитата:
Сообщение от Казанский Посмотреть сообщение
Пробуйте, работает с произвольным числом столбцов
Код:
Sub MergeSameCell()
Const xTitleId = "Programmersforum.ru"
Dim Rng As Range, xRows As Long, i&, j&, k&
  Set Rng = Application.Selection
  Set Rng = Application.InputBox("Range", xTitleId, Rng.Address, Type:=8)
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  xRows = Rng.Rows.Count + 1
  For i = 1 To xRows - 1
    For j = i + 1 To xRows
      For k = 1 To Rng.Columns.Count
        If Rng.Cells(i, k).Value <> Rng.Cells(j, k).Value Then GoTo 1
      Next
    Next
    GoTo 2
1   If j - i > 1 Then
      For k = 1 To Rng.Columns.Count
        Range(Rng.Cells(i, k), Rng.Cells(j - 1, k)).Merge
      Next
      i = j - 1
    End If
2 Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
То что надо. Спасибо огромное
Haney вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Макрос для объединения ячеек Lynx_by Microsoft Office Excel 1 22.08.2017 11:17
Сравнение текстовых(строковых) (строк,ячеек)массивов - с одинаковыми данными но по разному написанными! redyps Microsoft Office Excel 1 28.07.2013 15:58
макрос для объединения ячеек BAP9IT Microsoft Office Word 2 15.11.2012 19:43
Макрос для объединения одинаковых ячеек Internal2 Microsoft Office Excel 2 05.11.2009 14:00
Группировка в строку ячеек с одинаковыми данными Vanot Microsoft Office Excel 2 24.08.2009 01:01