Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Создание цикла перемещения ячеек с текстом
 
#1
20.03.2019 22:15:44
Привет нужна помощь с макросом
Есть файл с тестовыми вопросами и ответами, содержит 1200 вопросов, но формат и расположение вопросов и ответов нужно поменять.
В прикрепленном файле пример вида, на Листе2 оригинальный вид теста нужно поменять как на Листе1.
Нужно на столбце А после каждого вопроса добавить 3 строки потом из столбца Б взять 4 ответа и переместить в Столбец А после вопроса и все это зациклить до вопроса 1200.
И добавить нумерацию вопроса как на  Листе1.
По сути после каждого вопроса должен бить 6 строк первые 4 ответы 5 пустой и в шестом строке нумерация.

Вопросы никуда не надо переставлять только добавить строки и туда переместить ответы
Изменено: barbus - 21.03.2019 11:31:28
 
 
 
#2
20.03.2019 23:16:53
в a1 И тянуть до …
=IF(MOD(ROW()-1;7)+1=1;INT((ROW()-1)/7)+1;IF(MOD(ROW()-1;7)+1=2;INDEX(Лист2!A:A;(INT((ROW()-1)/7)+1-1)*4+2);IF(MOD(ROW()-1;7)+1=7;"";INDEX(Лист2!B:B;(INT((ROW()-1)/7)+1-1)*4+MOD(ROW()-1;7)))))
или
=CHOOSE(LOOKUP(MOD(ROW()-1;7)+1;{1;2;3;7};{1;2;3;4});INT((ROW()-1)/7)+1;INDEX(Лист2!A:A;(INT((ROW()-1)/7)+1-1)*4+2);INDEX(Лист2!B:B;(INT((ROW()-1)/7)+1-1)*4+MOD(ROW()-1;7));"")

Цитата
barbus написал:
Нужен макрос для автоматизации процесса
- эх, пропали формулы :-)
Изменено: БМВ - 20.03.2019 23:26:01
По вопросам из тем форума, личку не читаю.
 
 
 
#3
21.03.2019 11:13:31
БМВ,
Спасибо за помощь
Все работает
 
 
 
#4
23.03.2019 11:35:32
Есть еще проблема когда конвертировал с PDF to Excel то в тексте ячеек  есть переноси как "CTRL+Enter" как убрать их чтобы не было этих переносов,можно поробовать "find to replace" но не знач как обазначить "CTRL+Enter"
 
 
 
#5
23.03.2019 11:52:43
БМВ, для меня "накропать" такие Формулы:
Умереть не встать!     :(  :(  :(  
 
 
 
#6
23.03.2019 12:05:33
Цитата
barbus написал:
как обазначить "CTRL+Enter"
Alt+Enter наверно - в строке поиска вводится с помощью Ctrl+j
 
 
 
#7
23.03.2019 12:27:51
Цитата
barbus написал:
нужна помощь с макросом
Код
Sub Ba()
Dim a As Range, n&, r&
  n = 1
  Application.ScreenUpdating = False
  For Each a In Range("A2", Cells(Rows.Count, "A")).SpecialCells(xlCellTypeBlanks).Areas
    r = a.Rows.Count
    Rows(a.Row + r).Resize(3).Insert
    n = n + 1
    a(r + 3) = n
    Cells(a.Row - 1, 2).Resize(a.Rows.Count + 1).Cut a(1)
  Next
  Application.ScreenUpdating = True
End Sub
Число ответов может быть разным для разных вопросов.
 
 
 
#8
23.03.2019 13:20:36
Цитата
barbus написал:
как убрать их
покажите примерчик, может и сварганится что.

Цитата
Мотя написал:
для меня "накропать" такие
если все разобрать, то тут самые простые действия, просто в отличии от VBA, да и PQ, читаемость формул в разы хуже.
По вопросам из тем форума, личку не читаю.
 
 
 
#9
23.03.2019 14:33:13
Цитата
БМВ написал:
если все разобрать, то тут самые простые действия, просто в отличии от VBA, да и PQ, читаемость формул в разы хуже.
Когда я вижу недоступные для моего мозга Формулы - всегда хочется Авторам этих Формул сказать:
1. "Низкий поклон"!
2. «Respect и Уважуха»!
8)  8)  8)  
 
 
 
#10
23.03.2019 22:18:10
Цитата
БМВ написал:
читаемость формул в разы хуже
Они вообще нечитаемы ))
 
 
 
#11
23.03.2019 23:38:01
Цитата
БМВ написал:
просто в отличии от VBA, да и PQ, читаемость формул в разы хуже.
Михаил, вы просто не присматривались к местным талантам. И в Power Query можно так накрутить, что без бутылки не разберёшься. :)
 
 
 
#12
23.03.2019 23:48:28
Андрей VG,  Андрей, ну там хоть гипотетически можно структурировать, а в формуле - ( ну максимум на другую строку перенести, примечание написать, но это еще хуже может сделать.
Изменено: БМВ - 23.03.2019 23:49:05
По вопросам из тем форума, личку не читаю.
 
 
 
#13
24.03.2019 04:55:58
Цитата
Андрей VG написал:
И в Power Query можно так накрутить, что без бутылки не разберёшься.
ога :)
а для формул можно пользовать надстройку FormulaDesk
 
 
 
#14
24.03.2019 08:36:47
Off
Цитата
Андрей Лящук написал:
а для формул можно пользовать надстройку  FormulaDesk
Скачал, поставил, загрузил, посмотрел
Скрытый текст

Уж не знаю, на сколько это поможет разобрать сложные формулы, но  на 2й минуте :-)
Скрытый текст

Труда вложено не мало, а вот уровень пользы - мне не известен.
Изменено: БМВ - 24.03.2019 08:38:48
По вопросам из тем форума, личку не читаю.
 
 
 
#15
24.03.2019 11:03:05
Цитата
БМВ написал:
Скачал, поставил, загрузил, посмотрел
Хм, напоминает макроязык Excel4... все возвращается :)
 
 
 
#16
24.03.2019 11:10:13
Цитата
Казанский написал:
все возвращается
все еще не отпускает "Excel-4.0-Macro-Functions-Reference" держу под рукой :-)
По вопросам из тем форума, личку не читаю.
 
 
 
#17
25.03.2019 10:10:36
БМВ, Работают как формулы, так и CTRL+j все исправил. Осталось сделать шрифт вопросов жирными и все.
Сделал Fine & Replice в место Alt+Enter заменил пробелами

Казанский, Тебе тоже спасибо макрос тоже работает только бы добавить чтоб убирал из текстов CTRL+j поставлял пробелы в место них и делал шрифт вопросов жирными

Приятно иметь дело с знающими людьми.
Изменено: barbus - 31.03.2019 23:26:51
 
 
 
#18
25.03.2019 11:29:45
Цитата
barbus написал: Осталось сделать шрифт вопросов жирными
УФ
=MOD(ROW()-1;7)=1

Цитата
barbus написал:
Сделал Fine & Replice
:D  :D
Изменено: БМВ - 31.03.2019 23:27:07
По вопросам из тем форума, личку не читаю.
 
 
 
#19
25.03.2019 11:29:50
barbus, добавил 2 строки
Код
Sub Ba()
Dim a As Range, n&, r&
  n = 1
  Application.ScreenUpdating = False
  For Each a In Range("A2", Cells(Rows.Count, "A")).SpecialCells(xlCellTypeBlanks).Areas
    r = a.Rows.Count
    a(0).Font.Bold = True
    Rows(a.Row + r).Resize(3).Insert
    n = n + 1
    a(r + 3) = n
    Cells(a.Row - 1, 2).Resize(a.Rows.Count + 1).Cut a(1)
  Next
  Range("A:A").Replace vbLf, " ", xlPart, , , , False, False
  Application.ScreenUpdating = True
End Sub
 
 
 
#20
31.03.2019 18:36:53
Всем спасибо за помощь все работает.
 
 
 
Страницы: 1
Наверх