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

Регистрация

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

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

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Прошу помощи в изменении положения ячеек на листе (Макросы/Sub)

Прошу помощи в изменении положения ячеек на листе

Дата: Пятница, 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

Ответить

Дата: Пятница, 04.05.2018, 08:00 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4106

Репутация: 768 ±

Замечаний: 0% ±

Excel 2013/2016

Цитата RusUser, 04.05.2018 в 03:48, в сообщении № 1 ()

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

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

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

~~Замечательный~~ Временно просто медведь ~~, процентов на 20~~.

Ответить

Дата: Пятница, 04.05.2018, 10:18 | Сообщение № 3

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

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

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

Ответить

Дата: Пятница, 04.05.2018, 10:27 | Сообщение № 4

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

А если исходный формат поменять, как во вложении, проверка и вовсе в одну строку кода поместится.

К сообщению приложен файл: 2297959.xlsx (10.5 Kb)

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

Ответить

Дата: Пятница, 04.05.2018, 11:22 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

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

Ответить

Дата: Пятница, 04.05.2018, 11:24 | Сообщение № 6

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

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

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

Сообщение отредактировал StoTisteg - Пятница, 04.05.2018, 11:27

Ответить

Дата: Пятница, 04.05.2018, 11:26 | Сообщение № 7

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Преобразование разовое. У меня 40000 строк ... нужны не все, но все же.
Максимум правильных ответов 5
Вариантов от 2-х до 5 в разных тестах по разному

Ответить

Дата: Пятница, 04.05.2018, 11:29 | Сообщение № 8

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

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

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

Ответить

Дата: Пятница, 04.05.2018, 11:52 | Сообщение № 9

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Да, можно пустую

Ответить

Дата: Пятница, 04.05.2018, 12:13 | Сообщение № 10

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

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

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

Ответить

Дата: Пятница, 04.05.2018, 13:17 | Сообщение № 11

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Да, все верно

Ответить

Дата: Пятница, 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]
Макрос в начале удаляет все листы книги, кроме первого, поэтому на всякий случай скопируйте данные в мой файл, а не макрос в ваш.

К сообщению приложен файл: 3684882.xlsm (21.5 Kb)

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

Сообщение отредактировал StoTisteg - Пятница, 04.05.2018, 14:01

Ответить

Дата: Пятница, 04.05.2018, 16:37 | Сообщение № 13

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Спасибо огромное!
Макрос отлично работает.
Но пожалуй я поторопился, сказав что не нужно ничего делать с предметом.
По листу на предмет - было бы хорошо, но если бы каждый предмет был бы отдельной книгой - было бы идеально.
Хотя то что есть уже на 99 % решает мою задачу.
-
Закинул все строки и комп завис наглухо, слабая машинка у меня (

Ответить

Дата: Воскресенье, 06.05.2018, 19:13 | Сообщение № 14

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

Цитата RusUser, 04.05.2018 в 16:37, в сообщении № 13 ()

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

ОК, завтра добью.

Цитата RusUser, 04.05.2018 в 16:37, в сообщении № 13 ()

Закинул все строки и комп завис наглухо, слабая машинка у меня (

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

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

Ответить

Дата: Воскресенье, 06.05.2018, 19:21 | Сообщение № 15

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

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

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

Ответить

Дата: Понедельник, 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

К сообщению приложен файл: 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

Дата: Понедельник, 07.05.2018, 12:45 | Сообщение № 17

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Спасибо большое. Работает, но столкнулся с такой проблемой: если название предмета слишком длинное, то листы получаются без имени и самое главное если в тексте вопроса и ответа есть символы абзаца - все съезжает (см. вложение)

К сообщению приложен файл: 0961460.xlsm (28.6 Kb)

Ответить

Дата: Понедельник, 07.05.2018, 12:52 | Сообщение № 18

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата RusUser, 07.05.2018 в 12:45, в сообщении № 17 ()

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

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

killed

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Понедельник, 07.05.2018, 13:15 | Сообщение № 19

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

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

Ответить

Дата: Понедельник, 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

К сообщению приложен файл: 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-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!