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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: _Boroda_, Pelena, 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
Группа: Проверенные
Ранг: Старожил
Сообщений: 1261
Репутация: 214 ±
Замечаний: 0% ±

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

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

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

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

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

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

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


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

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

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеА если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится.

Автор - 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеХорошо. Что делаем, если вариантов меньше 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеИ я так понял, что у Вас все 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 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)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

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

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

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение
По листу на предмет - было бы хорошо

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

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

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

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеТолько под слабую машину потребуется файл, отсортированный сначала по формулировкам вопросов, потом по предметам..

Автор - StoTisteg
Дата добавления - 06.05.2018 в 19:21
StoTisteg Дата: Понедельник, 07.05.2018, 11:44 | Сообщение № 16
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 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)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал 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
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4817
Репутация: 968 ±
Замечаний: 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
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 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)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеТак?
[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 обязательна!