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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос переноса массива строк вниз, если вторая ячейка пуста - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос переноса массива строк вниз, если вторая ячейка пуста (Макросы/Sub)
Макрос переноса массива строк вниз, если вторая ячейка пуста
Yar4i4 Дата: Вторник, 16.02.2016, 10:01 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 55
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Доброе время.
Нужен макрос позволяющий перенести массив строк от фиксированной 20 строки и до первой строки (27 строка в примере, но м.б. иной), вторая ячейка которой пуста (всегда разная).
И перенести этот массив строк необходимо под последнюю строку (36 из примера, но м.б. иной), вторая ячейка которой пуста (всегда разная). Но эта строка - она имеет границы очерченные линиями.
(Я не знаю, как объяснить, чтоб не перепутать последнюю строку из таблицы с последней из "бороды" (45 строка))

Цвет для наглядности. В прикреплённом файле есть второй лист с желаемым итоговым видом.

Спасибо.
К сообщению приложен файл: 5555555.xlsx(16Kb)
 
Ответить
СообщениеДоброе время.
Нужен макрос позволяющий перенести массив строк от фиксированной 20 строки и до первой строки (27 строка в примере, но м.б. иной), вторая ячейка которой пуста (всегда разная).
И перенести этот массив строк необходимо под последнюю строку (36 из примера, но м.б. иной), вторая ячейка которой пуста (всегда разная). Но эта строка - она имеет границы очерченные линиями.
(Я не знаю, как объяснить, чтоб не перепутать последнюю строку из таблицы с последней из "бороды" (45 строка))

Цвет для наглядности. В прикреплённом файле есть второй лист с желаемым итоговым видом.

Спасибо.

Автор - Yar4i4
Дата добавления - 16.02.2016 в 10:01
Manyasha Дата: Вторник, 16.02.2016, 10:50 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1587
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
Yar4i4, можно так (на кнопку повесила):
[vba]
Код
Sub perenos()
    lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
    lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
    Range("A20:H" & lr2).Cut
    Range("A" & lr).Insert Shift:=xlDown
    Application.CutCopyMode = False
    Range("A20").WrapText = False
End Sub
[/vba]
К сообщению приложен файл: 5555555-1.xlsm(23Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеYar4i4, можно так (на кнопку повесила):
[vba]
Код
Sub perenos()
    lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
    lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
    Range("A20:H" & lr2).Cut
    Range("A" & lr).Insert Shift:=xlDown
    Application.CutCopyMode = False
    Range("A20").WrapText = False
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 16.02.2016 в 10:50
Апострофф Дата: Вторник, 16.02.2016, 10:59 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 26 ±
Замечаний: 0% ±

Excel 2003
[vba]
Код
Sub asd()
Dim r&
For r = 20 To Rows.Count
  If Cells(r, 1).Borders(xlEdgeRight).LineStyle = xlNone Then Exit For
Next r

Do
  Rows(r).Insert
  [b20].EntireRow.Copy Rows(r).EntireRow
  [b20].EntireRow.Delete
Loop While Cells(r - 1, 2) <> ""

End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub asd()
Dim r&
For r = 20 To Rows.Count
  If Cells(r, 1).Borders(xlEdgeRight).LineStyle = xlNone Then Exit For
Next r

Do
  Rows(r).Insert
  [b20].EntireRow.Copy Rows(r).EntireRow
  [b20].EntireRow.Delete
Loop While Cells(r - 1, 2) <> ""

End Sub
[/vba]

Автор - Апострофф
Дата добавления - 16.02.2016 в 10:59
Yar4i4 Дата: Вторник, 16.02.2016, 12:41 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 55
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013

Спасибо. Работает.

Цитата Апострофф, 16.02.2016 в 10:59, в сообщении № 3
Do

Спасибо.

По разному пытал макросы - срабатывают великолепно.
Спасибо.
 
Ответить
Сообщение
Спасибо. Работает.

Цитата Апострофф, 16.02.2016 в 10:59, в сообщении № 3
Do

Спасибо.

По разному пытал макросы - срабатывают великолепно.
Спасибо.

Автор - Yar4i4
Дата добавления - 16.02.2016 в 12:41
Yar4i4 Дата: Четверг, 25.02.2016, 06:35 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 55
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
можно

помогите пожалуйста .... не знаю как вставить редактирование массива, который переносим?
Хочу переносимый массив, а именно от A20 и до "неизвестной" H. выделить заливкой ячеек
т.е. первые восемь столбцов в переносимом массиве выделить цветом/заливкой (.Color = 15463915)
 
Ответить
Сообщение
можно

помогите пожалуйста .... не знаю как вставить редактирование массива, который переносим?
Хочу переносимый массив, а именно от A20 и до "неизвестной" H. выделить заливкой ячеек
т.е. первые восемь столбцов в переносимом массиве выделить цветом/заливкой (.Color = 15463915)

Автор - Yar4i4
Дата добавления - 25.02.2016 в 06:35
Yar4i4 Дата: Суббота, 05.03.2016, 07:04 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 55
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Разобрался с Select

[vba]
Код
Sub Макрос1()
' Макрос1 Макрос
   lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
   lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
   Range("A20:H" & lr2).Select
   With Selection.Interior
   .Pattern = xlSolid
   .PatternColorIndex = xlAutomatic
   .Color = 15463915
   .TintAndShade = 0
   .PatternTintAndShade = 0
   Range("A20:H" & lr2).Cut
   Range("A" & lr).Insert Shift:=xlDown
   Application.CutCopyMode = False
   Range("A20").WrapText = False
   End With
End Sub
[/vba]
оп.
П.С. (не могу редактировать свое прежнее сообщение, удалите его пожалуйста)
[moder]удалила[/moder]


Сообщение отредактировал Yar4i4 - Суббота, 05.03.2016, 07:08
 
Ответить
СообщениеРазобрался с Select

[vba]
Код
Sub Макрос1()
' Макрос1 Макрос
   lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
   lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
   Range("A20:H" & lr2).Select
   With Selection.Interior
   .Pattern = xlSolid
   .PatternColorIndex = xlAutomatic
   .Color = 15463915
   .TintAndShade = 0
   .PatternTintAndShade = 0
   Range("A20:H" & lr2).Cut
   Range("A" & lr).Insert Shift:=xlDown
   Application.CutCopyMode = False
   Range("A20").WrapText = False
   End With
End Sub
[/vba]
оп.
П.С. (не могу редактировать свое прежнее сообщение, удалите его пожалуйста)
[moder]удалила[/moder]

Автор - Yar4i4
Дата добавления - 05.03.2016 в 07:04
Manyasha Дата: Суббота, 05.03.2016, 16:09 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 1587
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
Yar4i4, ну Вы все правильно написали, просто цвет Вы задаете тот же, что и был. Поменяйте вот так, например (удалила из кода все лишнее)
[vba]
Код
Sub perenos()
    lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
    lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
    Range("A20:H" & lr2).Interior.Color = vbYellow '15463915
    Range("A20:H" & lr2).Cut
    Range("A" & lr).Insert Shift:=xlDown
    Application.CutCopyMode = False
    Range("A20").WrapText = False
End Sub
[/vba]


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеYar4i4, ну Вы все правильно написали, просто цвет Вы задаете тот же, что и был. Поменяйте вот так, например (удалила из кода все лишнее)
[vba]
Код
Sub perenos()
    lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
    lr2 = IIf(Cells(21, 2) <> "", Cells(20, 2).End(xlDown).Row, 20)
    Range("A20:H" & lr2).Interior.Color = vbYellow '15463915
    Range("A20:H" & lr2).Cut
    Range("A" & lr).Insert Shift:=xlDown
    Application.CutCopyMode = False
    Range("A20").WrapText = False
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 05.03.2016 в 16:09
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос переноса массива строк вниз, если вторая ячейка пуста (Макросы/Sub)
Страница 1 из 11
Поиск:

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