Прошу помощи в изменении положения ячеек на листе
RusUser
Дата: Пятница, 04.05.2018, 03:48 |
Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Здравствуйте у уважаемые гуру Excel'я! Прошу помощи в необычной для меня задаче. 1. Имеется список тестов по предметам (русский, математика, физики и т.п.) 2. Список в определенном формате, оставленный предыдущими работником, который на все забил, мол вот что есть, дальше как хотите. 3. Необходимо этот список тестов привести в необходимый формат, на чем я и затормозился. Файл примера во вложении
Здравствуйте у уважаемые гуру Excel'я! Прошу помощи в необычной для меня задаче. 1. Имеется список тестов по предметам (русский, математика, физики и т.п.) 2. Список в определенном формате, оставленный предыдущими работником, который на все забил, мол вот что есть, дальше как хотите. 3. Необходимо этот список тестов привести в необходимый формат, на чем я и затормозился. Файл примера во вложении RusUser
Сообщение отредактировал RusUser - Пятница, 04.05.2018, 03:49
Ответить
Сообщение Здравствуйте у уважаемые гуру Excel'я! Прошу помощи в необычной для меня задаче. 1. Имеется список тестов по предметам (русский, математика, физики и т.п.) 2. Список в определенном формате, оставленный предыдущими работником, который на все забил, мол вот что есть, дальше как хотите. 3. Необходимо этот список тестов привести в необходимый формат, на чем я и затормозился. Файл примера во вложении Автор - RusUser Дата добавления - 04.05.2018 в 03:48
bmv98rus
Дата: Пятница, 04.05.2018, 08:00 |
Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4106
Репутация:
768
±
Замечаний:
0% ±
Excel 2013/2016
оставленный предыдущими работником, который на все забил
Я б не спешил с такими выводами, формат как раз нормальный для автоматизации. Другое дело что он не совпадает с Вашим видением. Преобразование - это разовая или постоянная задача? Максимальное количество правильных ответов какое? Количество вариантов ответов на вопрос фиксировано?
оставленный предыдущими работником, который на все забил
Я б не спешил с такими выводами, формат как раз нормальный для автоматизации. Другое дело что он не совпадает с Вашим видением. Преобразование - это разовая или постоянная задача? Максимальное количество правильных ответов какое? Количество вариантов ответов на вопрос фиксировано?bmv98rus
Замечательный Временно просто медведь , процентов на 20 .
Ответить
Сообщение оставленный предыдущими работником, который на все забил
Я б не спешил с такими выводами, формат как раз нормальный для автоматизации. Другое дело что он не совпадает с Вашим видением. Преобразование - это разовая или постоянная задача? Максимальное количество правильных ответов какое? Количество вариантов ответов на вопрос фиксировано?Автор - bmv98rus Дата добавления - 04.05.2018 в 08:00
StoTisteg
Дата: Пятница, 04.05.2018, 10:18 |
Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
RusUser , преобразовать-то не проблема. Но мне тоже кажется, что исходный вариант удобнее для автоматизированной проверки. Просто потому, что в исходном варианте не нужно вытягивать ответ из строки, а достаточно просто проверить одно значение на 0/1.
RusUser , преобразовать-то не проблема. Но мне тоже кажется, что исходный вариант удобнее для автоматизированной проверки. Просто потому, что в исходном варианте не нужно вытягивать ответ из строки, а достаточно просто проверить одно значение на 0/1.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение RusUser , преобразовать-то не проблема. Но мне тоже кажется, что исходный вариант удобнее для автоматизированной проверки. Просто потому, что в исходном варианте не нужно вытягивать ответ из строки, а достаточно просто проверить одно значение на 0/1.Автор - StoTisteg Дата добавления - 04.05.2018 в 10:18
StoTisteg
Дата: Пятница, 04.05.2018, 10:27 |
Сообщение № 4
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
А если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится.
А если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится. StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение А если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится. Автор - StoTisteg Дата добавления - 04.05.2018 в 10:27
RusUser
Дата: Пятница, 04.05.2018, 11:22 |
Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Дело в том что формат, который мне нужен, это формат для импорта в программу для тестирования и тот формат, который есть мне не подходит ...
Дело в том что формат, который мне нужен, это формат для импорта в программу для тестирования и тот формат, который есть мне не подходит ... RusUser
Ответить
Сообщение Дело в том что формат, который мне нужен, это формат для импорта в программу для тестирования и тот формат, который есть мне не подходит ... Автор - RusUser Дата добавления - 04.05.2018 в 11:22
StoTisteg
Дата: Пятница, 04.05.2018, 11:24 |
Сообщение № 6
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
Тогда следующий вопрос — все названия тестов нужны на одном листе или по листу на предмет? И потом — в исходном у Вас 4 варианта ответа на 3 вопрос, а в конечном — 5.
Тогда следующий вопрос — все названия тестов нужны на одном листе или по листу на предмет? И потом — в исходном у Вас 4 варианта ответа на 3 вопрос, а в конечном — 5. StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Сообщение отредактировал StoTisteg - Пятница, 04.05.2018, 11:27
Ответить
Сообщение Тогда следующий вопрос — все названия тестов нужны на одном листе или по листу на предмет? И потом — в исходном у Вас 4 варианта ответа на 3 вопрос, а в конечном — 5. Автор - StoTisteg Дата добавления - 04.05.2018 в 11:24
RusUser
Дата: Пятница, 04.05.2018, 11:26 |
Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Преобразование разовое. У меня 40000 строк ... нужны не все, но все же. Максимум правильных ответов 5 Вариантов от 2-х до 5 в разных тестах по разному
Преобразование разовое. У меня 40000 строк ... нужны не все, но все же. Максимум правильных ответов 5 Вариантов от 2-х до 5 в разных тестах по разному RusUser
Ответить
Сообщение Преобразование разовое. У меня 40000 строк ... нужны не все, но все же. Максимум правильных ответов 5 Вариантов от 2-х до 5 в разных тестах по разному Автор - RusUser Дата добавления - 04.05.2018 в 11:26
StoTisteg
Дата: Пятница, 04.05.2018, 11:29 |
Сообщение № 8
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
Хорошо. Что делаем, если вариантов меньше 5? Оставляем пустую ячейку?
Хорошо. Что делаем, если вариантов меньше 5? Оставляем пустую ячейку? StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение Хорошо. Что делаем, если вариантов меньше 5? Оставляем пустую ячейку? Автор - StoTisteg Дата добавления - 04.05.2018 в 11:29
RusUser
Дата: Пятница, 04.05.2018, 11:52 |
Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Да, можно пустую
Ответить
Сообщение Да, можно пустую Автор - RusUser Дата добавления - 04.05.2018 в 11:52
StoTisteg
Дата: Пятница, 04.05.2018, 12:13 |
Сообщение № 10
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
И я так понял, что у Вас все 40 000 строк на одном листе и результат тоже нужен на одном листе, а название предмета игнорируем?
И я так понял, что у Вас все 40 000 строк на одном листе и результат тоже нужен на одном листе, а название предмета игнорируем? StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение И я так понял, что у Вас все 40 000 строк на одном листе и результат тоже нужен на одном листе, а название предмета игнорируем? Автор - StoTisteg Дата добавления - 04.05.2018 в 12:13
RusUser
Дата: Пятница, 04.05.2018, 13:17 |
Сообщение № 11
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Да, все верно
Ответить
Сообщение Да, все верно Автор - RusUser Дата добавления - 04.05.2018 в 13:17
StoTisteg
Дата: Пятница, 04.05.2018, 13:23 |
Сообщение № 12
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
[vba]Код
Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop Worksheets.Add after:=Worksheets(1) Range(Cells(1, 1), Cells(1, 2)).Value = Array("íîìåð âîïðîñà", "òåêñò âîïðîñà") For i = 1 To 5 Cells(1, i + 2).Value = "âàðèàíò îòâåòà " & i Next i Cells(1, 8).Value = "âåðíûé îòâåò" With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next rw = Columns(2).Find(what:=.Cells(i, 3).Value, lookat:=xlWhole, LookIn:=xlValues).Row If Err.Number <> 0 Then rw = Cells(Rows.Count, 1).End(xlUp).Row + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba] Макрос в начале удаляет все листы книги, кроме первого, поэтому на всякий случай скопируйте данные в мой файл, а не макрос в ваш.
[vba]Код
Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop Worksheets.Add after:=Worksheets(1) Range(Cells(1, 1), Cells(1, 2)).Value = Array("íîìåð âîïðîñà", "òåêñò âîïðîñà") For i = 1 To 5 Cells(1, i + 2).Value = "âàðèàíò îòâåòà " & i Next i Cells(1, 8).Value = "âåðíûé îòâåò" With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next rw = Columns(2).Find(what:=.Cells(i, 3).Value, lookat:=xlWhole, LookIn:=xlValues).Row If Err.Number <> 0 Then rw = Cells(Rows.Count, 1).End(xlUp).Row + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba] Макрос в начале удаляет все листы книги, кроме первого, поэтому на всякий случай скопируйте данные в мой файл, а не макрос в ваш. StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Сообщение отредактировал StoTisteg - Пятница, 04.05.2018, 14:01
Ответить
Сообщение [vba]Код
Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop Worksheets.Add after:=Worksheets(1) Range(Cells(1, 1), Cells(1, 2)).Value = Array("íîìåð âîïðîñà", "òåêñò âîïðîñà") For i = 1 To 5 Cells(1, i + 2).Value = "âàðèàíò îòâåòà " & i Next i Cells(1, 8).Value = "âåðíûé îòâåò" With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next rw = Columns(2).Find(what:=.Cells(i, 3).Value, lookat:=xlWhole, LookIn:=xlValues).Row If Err.Number <> 0 Then rw = Cells(Rows.Count, 1).End(xlUp).Row + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba] Макрос в начале удаляет все листы книги, кроме первого, поэтому на всякий случай скопируйте данные в мой файл, а не макрос в ваш. Автор - StoTisteg Дата добавления - 04.05.2018 в 13:23
RusUser
Дата: Пятница, 04.05.2018, 16:37 |
Сообщение № 13
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Спасибо огромное! Макрос отлично работает. Но пожалуй я поторопился, сказав что не нужно ничего делать с предметом. По листу на предмет - было бы хорошо, но если бы каждый предмет был бы отдельной книгой - было бы идеально. Хотя то что есть уже на 99 % решает мою задачу. - Закинул все строки и комп завис наглухо, слабая машинка у меня (
Спасибо огромное! Макрос отлично работает. Но пожалуй я поторопился, сказав что не нужно ничего делать с предметом. По листу на предмет - было бы хорошо, но если бы каждый предмет был бы отдельной книгой - было бы идеально. Хотя то что есть уже на 99 % решает мою задачу. - Закинул все строки и комп завис наглухо, слабая машинка у меня ( RusUser
Ответить
Сообщение Спасибо огромное! Макрос отлично работает. Но пожалуй я поторопился, сказав что не нужно ничего делать с предметом. По листу на предмет - было бы хорошо, но если бы каждый предмет был бы отдельной книгой - было бы идеально. Хотя то что есть уже на 99 % решает мою задачу. - Закинул все строки и комп завис наглухо, слабая машинка у меня ( Автор - RusUser Дата добавления - 04.05.2018 в 16:37
StoTisteg
Дата: Воскресенье, 06.05.2018, 19:13 |
Сообщение № 14
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
По листу на предмет - было бы хорошо
ОК, завтра добью.Закинул все строки и комп завис наглухо, слабая машинка у меня (
Это не машинка, это алгоритм такой, одноразовый и прямой как палка. Хотя если у Вас там меньше гига оперативы...
По листу на предмет - было бы хорошо
ОК, завтра добью.Закинул все строки и комп завис наглухо, слабая машинка у меня (
Это не машинка, это алгоритм такой, одноразовый и прямой как палка. Хотя если у Вас там меньше гига оперативы...StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение По листу на предмет - было бы хорошо
ОК, завтра добью.Закинул все строки и комп завис наглухо, слабая машинка у меня (
Это не машинка, это алгоритм такой, одноразовый и прямой как палка. Хотя если у Вас там меньше гига оперативы...Автор - StoTisteg Дата добавления - 06.05.2018 в 19:13
StoTisteg
Дата: Воскресенье, 06.05.2018, 19:21 |
Сообщение № 15
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
Только под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам..
Только под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам.. StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение Только под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам.. Автор - StoTisteg Дата добавления - 06.05.2018 в 19:21
StoTisteg
Дата: Понедельник, 07.05.2018, 11:44 |
Сообщение № 16
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
Переделал с разбивкой по предметам. Теперь работает немного медленнее, зато оперативы жрёт меньше, меньше риск зависания. [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next Worksheets(.Cells(i, 1).Value).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = .Cells(i, 1).Value Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Cells(rw, 2).Value <> .Cells(i, 3).Value Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba]
Переделал с разбивкой по предметам. Теперь работает немного медленнее, зато оперативы жрёт меньше, меньше риск зависания. [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next Worksheets(.Cells(i, 1).Value).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = .Cells(i, 1).Value Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Cells(rw, 2).Value <> .Cells(i, 3).Value Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba] StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Сообщение отредактировал StoTisteg - Понедельник, 07.05.2018, 11:47
Ответить
Сообщение Переделал с разбивкой по предметам. Теперь работает немного медленнее, зато оперативы жрёт меньше, меньше риск зависания. [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Err.Clear On Error Resume Next Worksheets(.Cells(i, 1).Value).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = .Cells(i, 1).Value Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Cells(rw, 2).Value <> .Cells(i, 3).Value Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With End Sub
[/vba] Автор - StoTisteg Дата добавления - 07.05.2018 в 11:44
RusUser
Дата: Понедельник, 07.05.2018, 12:45 |
Сообщение № 17
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Спасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение)
Спасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение) RusUser
Ответить
Сообщение Спасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение) Автор - RusUser Дата добавления - 07.05.2018 в 12:45
RAN
Дата: Понедельник, 07.05.2018, 12:52 |
Сообщение № 18
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
если название предмета слишком длинное
Что-же это за предмет? "Закон божий на старославянском языке?"
если название предмета слишком длинное
Что-же это за предмет? "Закон божий на старославянском языке?" RAN
Быть или не быть, вот в чем загвоздка!
Ответить
Сообщение если название предмета слишком длинное
Что-же это за предмет? "Закон божий на старославянском языке?" Автор - RAN Дата добавления - 07.05.2018 в 12:52
RusUser
Дата: Понедельник, 07.05.2018, 13:15 |
Сообщение № 19
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация:
0
±
Замечаний:
0% ±
Excel 2016
Да нет на русском, просто тесты делали разные люди и нет порядка в именовании, сейчас сижу все привожу к единому знаменателю - Попробовал убрать все символы "абзаца" и сократил кол-во символов в названии предметов. все шустренько получилось (пробовал на 200 строках)
Да нет на русском, просто тесты делали разные люди и нет порядка в именовании, сейчас сижу все привожу к единому знаменателю - Попробовал убрать все символы "абзаца" и сократил кол-во символов в названии предметов. все шустренько получилось (пробовал на 200 строках) RusUser
Ответить
Сообщение Да нет на русском, просто тесты делали разные люди и нет порядка в именовании, сейчас сижу все привожу к единому знаменателю - Попробовал убрать все символы "абзаца" и сократил кол-во символов в названии предметов. все шустренько получилось (пробовал на 200 строках) Автор - RusUser Дата добавления - 07.05.2018 в 13:15
StoTisteg
Дата: Понедельник, 07.05.2018, 13:18 |
Сообщение № 20
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация:
103
±
Замечаний:
0% ±
Excel 2010
Так? [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Dim wsn As String Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next wsn = Replace(Left(.Cells(i, 1).Value, 31), Chr(13), "", 1, -1, vbBinaryCompare) Err.Clear On Error Resume Next Worksheets(wsn).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = wsn Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Replace(Cells(rw, 2).Value, Chr(13), "", 1, -1, vbBinaryCompare) <> Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно .Cells(i, 3).Value = Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If .Cells(i, 4).Value = Replace(.Cells(i, 4).Value, Chr(13), "", 1, -1, vbBinaryCompare) Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With ThisWorkbook.Save End Sub
[/vba]
Так? [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Dim wsn As String Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next wsn = Replace(Left(.Cells(i, 1).Value, 31), Chr(13), "", 1, -1, vbBinaryCompare) Err.Clear On Error Resume Next Worksheets(wsn).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = wsn Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Replace(Cells(rw, 2).Value, Chr(13), "", 1, -1, vbBinaryCompare) <> Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно .Cells(i, 3).Value = Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If .Cells(i, 4).Value = Replace(.Cells(i, 4).Value, Chr(13), "", 1, -1, vbBinaryCompare) Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With ThisWorkbook.Save End Sub
[/vba] StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Ответить
Сообщение Так? [vba]Код
Option Explicit Sub ReFormat() Dim i As Long, rw As Long Dim Верно As String Dim cnt As Integer, j As Integer Dim wsn As String Worksheets(1).Activate Application.DisplayAlerts = False Err.Clear Do While Err.Number = 0 On Error Resume Next Worksheets(2).Delete Loop With Worksheets(1).Sort With .SortFields .Clear .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply With .SortFields .Clear .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Worksheets(1) Верно = "" cnt = 0 For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next wsn = Replace(Left(.Cells(i, 1).Value, 31), Chr(13), "", 1, -1, vbBinaryCompare) Err.Clear On Error Resume Next Worksheets(wsn).Activate If Err.Number <> 0 Then If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 8).Value = Верно Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = wsn Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса") For j = 1 To 5 Cells(1, j + 2).Value = "вариант ответа " & j Next j Cells(1, 8).Value = "верный ответ" End If rw = Cells(Rows.Count, 1).End(xlUp).Row If Replace(Cells(rw, 2).Value, Chr(13), "", 1, -1, vbBinaryCompare) <> Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Then rw = rw + 1 If rw > 2 Then Cells(rw - 1, 8).Value = Верно .Cells(i, 3).Value = Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value) Верно = "" cnt = 0 End If .Cells(i, 4).Value = Replace(.Cells(i, 4).Value, Chr(13), "", 1, -1, vbBinaryCompare) Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value cnt = cnt + 1 If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt) Next i Cells(rw, 8).Value = Верно End With ThisWorkbook.Save End Sub
[/vba] Автор - StoTisteg Дата добавления - 07.05.2018 в 13:18