Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Объединение ячеек с одинаковыми значениями - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение ячеек с одинаковыми значениями (Макросы/Sub)
Объединение ячеек с одинаковыми значениями
ZatX Дата: Вторник, 23.05.2017, 21:46 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Доброе время суток, Господа! Помогите пожалуйста с макросом. Нужно объединить ячейки с одинаковыми значениями в сформировавшемся файле, на листе "Заказ", в колонке "Склад и магазины". Файл и скрин с желаемым результатом прилагаю.
К сообщению приложен файл: 5346463.png (55.0 Kb) · 2676495.xls (58.0 Kb)


Сообщение отредактировал ZatX - Вторник, 23.05.2017, 21:56
 
Ответить
СообщениеДоброе время суток, Господа! Помогите пожалуйста с макросом. Нужно объединить ячейки с одинаковыми значениями в сформировавшемся файле, на листе "Заказ", в колонке "Склад и магазины". Файл и скрин с желаемым результатом прилагаю.
Автор - ZatX
Дата добавления - 23.05.2017 в 21:46
Pelena Дата: Вторник, 23.05.2017, 21:56 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19177
Репутация: 4417 ±
Замечаний: ±

Excel 365 & Mac Excel
Здравствуйте.
Обязательно макрос? Сводная не подойдёт?
К сообщению приложен файл: 9477593.xls (69.0 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Обязательно макрос? Сводная не подойдёт?
Автор - Pelena
Дата добавления - 23.05.2017 в 21:56
ZatX Дата: Вторник, 23.05.2017, 22:01 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Pelena, Спасибо за альтернативный вариант! Но этот файл "Заказ" Обрабатывается программой, и именно такой формат как на скрине нужен.
 
Ответить
СообщениеPelena, Спасибо за альтернативный вариант! Но этот файл "Заказ" Обрабатывается программой, и именно такой формат как на скрине нужен.
Автор - ZatX
Дата добавления - 23.05.2017 в 22:01
ZatX Дата: Среда, 24.05.2017, 11:39 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Нашёл подходящий макрос, но как его адаптировать под мои нужды?)

[vba]
Код
Sub Ob()
Dim i&, n&, arr, rn&
n = Cells(Rows.Count, 1).End(xlUp).Row + 1

Range("A1:A" & n - 1).MergeCells = False
For r = 2 To n - 1
    If Cells(r, 1) = "" Then Cells(r, 1) = Cells(r - 1, 1)
Next r
arr = Cells(1, 1).Resize(n)
rn = 1
Application.DisplayAlerts = False
For i = 2 To n
If arr(i, 1) <> arr(i - 1, 1) Then
With Range(Cells(rn, 1), Cells(i - 1, 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
rn = i
End If
Next
Application.DisplayAlerts = True
End Sub
[/vba]
 
Ответить
СообщениеНашёл подходящий макрос, но как его адаптировать под мои нужды?)

[vba]
Код
Sub Ob()
Dim i&, n&, arr, rn&
n = Cells(Rows.Count, 1).End(xlUp).Row + 1

Range("A1:A" & n - 1).MergeCells = False
For r = 2 To n - 1
    If Cells(r, 1) = "" Then Cells(r, 1) = Cells(r - 1, 1)
Next r
arr = Cells(1, 1).Resize(n)
rn = 1
Application.DisplayAlerts = False
For i = 2 To n
If arr(i, 1) <> arr(i - 1, 1) Then
With Range(Cells(rn, 1), Cells(i - 1, 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
rn = i
End If
Next
Application.DisplayAlerts = True
End Sub
[/vba]
Автор - ZatX
Дата добавления - 24.05.2017 в 11:39
sboy Дата: Среда, 24.05.2017, 12:15 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
Вот такая добавочка в Ваш макрос
[vba]
Код
'----------------
    Application.DisplayAlerts = False
    lr = Cells(Rows.Count, 5).End(xlUp).Row
    xr1 = 2
    Do While xr1 < lr
        xr2 = Cells(xr1, 5).End(xlDown).Row
        With Range(Cells(xr1, 5), Cells(xr2, 5))
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        xr1 = xr2 + 2
    Loop
    Application.DisplayAlerts = True
'--------------
[/vba]
К сообщению приложен файл: 3342144.xls (61.0 Kb)

Яндекс: 410016850021169
 
Ответить
СообщениеДобрый день.
Вот такая добавочка в Ваш макрос
[vba]
Код
'----------------
    Application.DisplayAlerts = False
    lr = Cells(Rows.Count, 5).End(xlUp).Row
    xr1 = 2
    Do While xr1 < lr
        xr2 = Cells(xr1, 5).End(xlDown).Row
        With Range(Cells(xr1, 5), Cells(xr2, 5))
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        xr1 = xr2 + 2
    Loop
    Application.DisplayAlerts = True
'--------------
[/vba]
Автор - sboy
Дата добавления - 24.05.2017 в 12:15
ZatX Дата: Среда, 24.05.2017, 12:58 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
sboy, всё круто!) Спасибо большое.+1 Вам к карме)
 
Ответить
Сообщениеsboy, всё круто!) Спасибо большое.+1 Вам к карме)
Автор - ZatX
Дата добавления - 24.05.2017 в 12:58
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение ячеек с одинаковыми значениями (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!