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

Вход

Регистрация

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

 

= Мир MS Excel/Объединение ячеек с удалением лишних строк - Мир MS Excel

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

2010
Заранее прошу прощения, за, возможно, нарушение правил по части 1 пост - 1 вопрос, просто не представляю, как разбить этот процесс на логические части.

Смысл в том, чтобы макрос склеил значения из указанной строки (7) со значениями из строки сверху (6) через пробел с вытиранием лишних пробелов (аналогично функции СЖПРОБЕЛЫ), и дропнул все лишние строки сверху, чтобы полученное значение встало в строку 1.

По файлу-примеру, в строке №1 должно появиться:
А1 - Заголовок1
...
Е1 - Верхнеуровневый Заголовок5
...
Благодарю!
К сообщению приложен файл: 2547784.xlsx (9.3 Kb)


Сообщение отредактировал ArkaIIIa - Воскресенье, 13.08.2017, 23:10
 
Ответить
СообщениеЗаранее прошу прощения, за, возможно, нарушение правил по части 1 пост - 1 вопрос, просто не представляю, как разбить этот процесс на логические части.

Смысл в том, чтобы макрос склеил значения из указанной строки (7) со значениями из строки сверху (6) через пробел с вытиранием лишних пробелов (аналогично функции СЖПРОБЕЛЫ), и дропнул все лишние строки сверху, чтобы полученное значение встало в строку 1.

По файлу-примеру, в строке №1 должно появиться:
А1 - Заголовок1
...
Е1 - Верхнеуровневый Заголовок5
...
Благодарю!

Автор - ArkaIIIa
Дата добавления - 13.08.2017 в 21:43
sboy Дата: Понедельник, 14.08.2017, 09:21 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
А просто формулой не то?
Код
=СЖПРОБЕЛЫ(A6&" "&A7)
К сообщению приложен файл: 2462381.xlsx (9.9 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеДобрый день.
А просто формулой не то?
Код
=СЖПРОБЕЛЫ(A6&" "&A7)

Автор - sboy
Дата добавления - 14.08.2017 в 09:21
ArkaIIIa Дата: Понедельник, 14.08.2017, 09:26 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 894
Репутация: 115 ±
Замечаний: 0% ±

2010
Добрый! Нет, формулой не то. Нужно макросом.

Нашел на сайте Майкрософта пример со сцеплением столбцов. Но что-то и он не работает...

[vba]
Код
Sub ConcatColumns()

   Do While ActiveCell <> ""  'Повторение цикла до пустой активной ячейки.

      ActiveCell.Offset(0, 1).FormulaR1C1 = _
         ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0)

      ActiveCell.Offset(1, 0).Select
   Loop

End Sub
[/vba]


Сообщение отредактировал ArkaIIIa - Понедельник, 14.08.2017, 09:27
 
Ответить
СообщениеДобрый! Нет, формулой не то. Нужно макросом.

Нашел на сайте Майкрософта пример со сцеплением столбцов. Но что-то и он не работает...

[vba]
Код
Sub ConcatColumns()

   Do While ActiveCell <> ""  'Повторение цикла до пустой активной ячейки.

      ActiveCell.Offset(0, 1).FormulaR1C1 = _
         ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0)

      ActiveCell.Offset(1, 0).Select
   Loop

End Sub
[/vba]

Автор - ArkaIIIa
Дата добавления - 14.08.2017 в 09:26
_Boroda_ Дата: Понедельник, 14.08.2017, 09:39 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Так нужно?
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    c0_ = 1
    If Cells(1, c0_) = "" Then
        r1_ = Cells(1, c0_).End(xlDown).Row
    Else
        r1_ = 2'если в первой строке что-то есть, то это будет верхнеуровневый заголовок
    End If
    c1_ = Cells(r1_, Columns.Count).End(xlToLeft).Column
    For i = c0_ To c1_
        Cells(r1_, i) = WorksheetFunction.Trim(Cells(r1_ - 1, i) & " " & Cells(r1_, i))
    Next i
    Cells(r1_, c0_).Resize(1, c1_ - c0_ + 1).WrapText = True'перенос текста в ячейках
    Cells(1, c0_).Resize(r1_ - r0_ - 1).EntireRow.Delete
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: 2547784_1.xlsm (17.3 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТак нужно?
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    c0_ = 1
    If Cells(1, c0_) = "" Then
        r1_ = Cells(1, c0_).End(xlDown).Row
    Else
        r1_ = 2'если в первой строке что-то есть, то это будет верхнеуровневый заголовок
    End If
    c1_ = Cells(r1_, Columns.Count).End(xlToLeft).Column
    For i = c0_ To c1_
        Cells(r1_, i) = WorksheetFunction.Trim(Cells(r1_ - 1, i) & " " & Cells(r1_, i))
    Next i
    Cells(r1_, c0_).Resize(1, c1_ - c0_ + 1).WrapText = True'перенос текста в ячейках
    Cells(1, c0_).Resize(r1_ - r0_ - 1).EntireRow.Delete
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 14.08.2017 в 09:39
sboy Дата: Понедельник, 14.08.2017, 10:08 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Еще вариант
[vba]
Код
Sub Надо_Макросом()
Dim st_()
Set r_ = Range(Cells(1), Cells.SpecialCells(xlCellTypeLastCell))
ifr = r_.Find(what:="*", after:=Cells(1), searchorder:=xlByRows).Row
ic1 = Cells(ifr, Columns.Count).End(xlToLeft).Column
ic2 = Cells(ifr + 1, Columns.Count).End(xlToLeft).Column
m_ = WorksheetFunction.Max(ic1, ic2)
st1_ = Range(Cells(ifr, 1), Cells(ifr, m_)).Value
st2_ = Range(Cells(ifr + 1, 1), Cells(ifr + 1, m_)).Value
ReDim st_(1 To m_)
    For x = 1 To m_
        st_(x) = Trim(st1_(1, x) & " " & st2_(1, x))
    Next x
Rows("1:" & ifr).Delete xlShiftUp
Cells(1).Resize(1, m_) = st_
End Sub
[/vba]
К сообщению приложен файл: 2547784.xlsm (17.1 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеЕще вариант
[vba]
Код
Sub Надо_Макросом()
Dim st_()
Set r_ = Range(Cells(1), Cells.SpecialCells(xlCellTypeLastCell))
ifr = r_.Find(what:="*", after:=Cells(1), searchorder:=xlByRows).Row
ic1 = Cells(ifr, Columns.Count).End(xlToLeft).Column
ic2 = Cells(ifr + 1, Columns.Count).End(xlToLeft).Column
m_ = WorksheetFunction.Max(ic1, ic2)
st1_ = Range(Cells(ifr, 1), Cells(ifr, m_)).Value
st2_ = Range(Cells(ifr + 1, 1), Cells(ifr + 1, m_)).Value
ReDim st_(1 To m_)
    For x = 1 To m_
        st_(x) = Trim(st1_(1, x) & " " & st2_(1, x))
    Next x
Rows("1:" & ifr).Delete xlShiftUp
Cells(1).Resize(1, m_) = st_
End Sub
[/vba]

Автор - sboy
Дата добавления - 14.08.2017 в 10:08
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение ячеек с удалением лишних строк (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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