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

Вход

Регистрация

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

 

= Мир MS Excel/Прошу помощи в изменении положения ячеек на листе - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Прошу помощи в изменении положения ячеек на листе (Макросы/Sub)
Прошу помощи в изменении положения ячеек на листе
RusUser Дата: Пятница, 04.05.2018, 03:48 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Здравствуйте у уважаемые гуру Excel'я!
Прошу помощи в необычной для меня задаче.
1. Имеется список тестов по предметам (русский, математика, физики и т.п.)
2. Список в определенном формате, оставленный предыдущими работником, который на все забил, мол вот что есть, дальше как хотите.
3. Необходимо этот список тестов привести в необходимый формат, на чем я и затормозился.
Файл примера во вложении
К сообщению приложен файл: 0873916.xlsx(10.0 Kb)


Сообщение отредактировал RusUser - Пятница, 04.05.2018, 03:49
 
Ответить
СообщениеЗдравствуйте у уважаемые гуру Excel'я!
Прошу помощи в необычной для меня задаче.
1. Имеется список тестов по предметам (русский, математика, физики и т.п.)
2. Список в определенном формате, оставленный предыдущими работником, который на все забил, мол вот что есть, дальше как хотите.
3. Необходимо этот список тестов привести в необходимый формат, на чем я и затормозился.
Файл примера во вложении

Автор - RusUser
Дата добавления - 04.05.2018 в 03:48
bmv98rus Дата: Пятница, 04.05.2018, 08:00 | Сообщение № 2
Группа: Проверенные
Ранг: Старожил
Сообщений: 1332
Репутация: 227 ±
Замечаний: 0% ±

Excel 2013/2016
оставленный предыдущими работником, который на все забил

Я б не спешил с такими выводами, формат как раз нормальный для автоматизации. Другое дело что он не совпадает с Вашим видением.

Преобразование - это разовая или постоянная задача?
Максимальное количество правильных ответов какое?
Количество вариантов ответов на вопрос фиксировано?
 
Ответить
Сообщение
оставленный предыдущими работником, который на все забил

Я б не спешил с такими выводами, формат как раз нормальный для автоматизации. Другое дело что он не совпадает с Вашим видением.

Преобразование - это разовая или постоянная задача?
Максимальное количество правильных ответов какое?
Количество вариантов ответов на вопрос фиксировано?

Автор - bmv98rus
Дата добавления - 04.05.2018 в 08:00
StoTisteg Дата: Пятница, 04.05.2018, 10:18 | Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
RusUser, преобразовать-то не проблема. Но мне тоже кажется, что исходный вариант удобнее для автоматизированной проверки. Просто потому, что в исходном варианте не нужно вытягивать ответ из строки, а достаточно просто проверить одно значение на 0/1.


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеRusUser, преобразовать-то не проблема. Но мне тоже кажется, что исходный вариант удобнее для автоматизированной проверки. Просто потому, что в исходном варианте не нужно вытягивать ответ из строки, а достаточно просто проверить одно значение на 0/1.

Автор - StoTisteg
Дата добавления - 04.05.2018 в 10:18
StoTisteg Дата: Пятница, 04.05.2018, 10:27 | Сообщение № 4
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
А если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится.
К сообщению приложен файл: 2297959.xlsx(10.5 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеА если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится.

Автор - StoTisteg
Дата добавления - 04.05.2018 в 10:27
RusUser Дата: Пятница, 04.05.2018, 11:22 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Дело в том что формат, который мне нужен, это формат для импорта в программу для тестирования и тот формат, который есть мне не подходит ...
 
Ответить
СообщениеДело в том что формат, который мне нужен, это формат для импорта в программу для тестирования и тот формат, который есть мне не подходит ...

Автор - RusUser
Дата добавления - 04.05.2018 в 11:22
StoTisteg Дата: Пятница, 04.05.2018, 11:24 | Сообщение № 6
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Тогда следующий вопрос — все названия тестов нужны на одном листе или по листу на предмет? И потом — в исходном у Вас 4 варианта ответа на 3 вопрос, а в конечном — 5.


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал 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
Дата добавления - 04.05.2018 в 11:26
StoTisteg Дата: Пятница, 04.05.2018, 11:29 | Сообщение № 8
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Хорошо. Что делаем, если вариантов меньше 5? Оставляем пустую ячейку?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеХорошо. Что делаем, если вариантов меньше 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
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
И я так понял, что у Вас все 40 000 строк на одном листе и результат тоже нужен на одном листе, а название предмета игнорируем?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеИ я так понял, что у Вас все 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
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 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]
Макрос в начале удаляет все листы книги, кроме первого, поэтому на всякий случай скопируйте данные в мой файл, а не макрос в ваш.
К сообщению приложен файл: 3684882.xlsm(21.5 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал 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
Дата добавления - 04.05.2018 в 16:37
StoTisteg Дата: Воскресенье, 06.05.2018, 19:13 | Сообщение № 14
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
По листу на предмет - было бы хорошо

ОК, завтра добью.
Закинул все строки и комп завис наглухо, слабая машинка у меня (

Это не машинка, это алгоритм такой, одноразовый и прямой как палка. Хотя если у Вас там меньше гига оперативы...


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение
По листу на предмет - было бы хорошо

ОК, завтра добью.
Закинул все строки и комп завис наглухо, слабая машинка у меня (

Это не машинка, это алгоритм такой, одноразовый и прямой как палка. Хотя если у Вас там меньше гига оперативы...

Автор - StoTisteg
Дата добавления - 06.05.2018 в 19:13
StoTisteg Дата: Воскресенье, 06.05.2018, 19:21 | Сообщение № 15
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Только под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам..


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеТолько под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам..

Автор - StoTisteg
Дата добавления - 06.05.2018 в 19:21
StoTisteg Дата: Понедельник, 07.05.2018, 11:44 | Сообщение № 16
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 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]
К сообщению приложен файл: 3417092.xlsm(28.2 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал 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
Спасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение)
К сообщению приложен файл: 0961460.xlsm(28.6 Kb)
 
Ответить
СообщениеСпасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение)

Автор - RusUser
Дата добавления - 07.05.2018 в 12:45
RAN Дата: Понедельник, 07.05.2018, 12:52 | Сообщение № 18
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4855
Репутация: 971 ±
Замечаний: 0% ±

2010
если название предмета слишком длинное

Что-же это за предмет?
"Закон божий на старославянском языке?"
killed


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
если название предмета слишком длинное

Что-же это за предмет?
"Закон божий на старославянском языке?"
killed

Автор - RAN
Дата добавления - 07.05.2018 в 12:52
RusUser Дата: Понедельник, 07.05.2018, 13:15 | Сообщение № 19
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Да нет на русском, просто тесты делали разные люди и нет порядка в именовании, сейчас сижу все привожу к единому знаменателю
-
Попробовал убрать все символы "абзаца" и сократил кол-во символов в названии предметов. все шустренько получилось (пробовал на 200 строках)
 
Ответить
СообщениеДа нет на русском, просто тесты делали разные люди и нет порядка в именовании, сейчас сижу все привожу к единому знаменателю
-
Попробовал убрать все символы "абзаца" и сократил кол-во символов в названии предметов. все шустренько получилось (пробовал на 200 строках)

Автор - RusUser
Дата добавления - 07.05.2018 в 13:15
StoTisteg Дата: Понедельник, 07.05.2018, 13:18 | Сообщение № 20
Группа: Авторы
Ранг: Старожил
Сообщений: 1017
Репутация: 86 ±
Замечаний: 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]
К сообщению приложен файл: 6976359.xlsm(29.6 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеТак?
[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
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Прошу помощи в изменении положения ячеек на листе (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

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