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

Вход

Регистрация

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

 

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

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

Excel 2016
Отлично!
Один препод выставил аж 10! вариантов ответов, не соображу, где подправить ..
У меня уже 9 вечера почти
 
Ответить
СообщениеОтлично!
Один препод выставил аж 10! вариантов ответов, не соображу, где подправить ..
У меня уже 9 вечера почти

Автор - RusUser
Дата добавления - 07.05.2018 в 13:50
StoTisteg Дата: Понедельник, 07.05.2018, 14:12 | Сообщение № 22
Группа: Авторы
Ранг: Ветеран
Сообщений: 749
Репутация: 58 ±
Замечаний: 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, 13).Value = Верно
            Worksheets.Add after:=Worksheets(Sheets.Count)
            ActiveSheet.Name = wsn
            Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса")
            For j = 1 To 10
            Cells(1, j + 2).Value = "вариант ответа " & j
            Next j
            Cells(1, 13).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, 13).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, 13).Value = Верно
End With
ThisWorkbook.Save
[/vba]


Проверь всё. 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, 13).Value = Верно
            Worksheets.Add after:=Worksheets(Sheets.Count)
            ActiveSheet.Name = wsn
            Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса")
            For j = 1 To 10
            Cells(1, j + 2).Value = "вариант ответа " & j
            Next j
            Cells(1, 13).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, 13).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, 13).Value = Верно
End With
ThisWorkbook.Save
[/vba]

Автор - StoTisteg
Дата добавления - 07.05.2018 в 14:12
StoTisteg Дата: Понедельник, 07.05.2018, 14:17 | Сообщение № 23
Группа: Авторы
Ранг: Ветеран
Сообщений: 749
Репутация: 58 ±
Замечаний: 0% ±

Excel 2010
В общем и в целом — правим номер столбца там, где используется переменная Верно (выставляем номер колонки число ответов плюс 3), там, где заголовок "верный ответ" (то же) и там, где в цикле крутится "вариант ответа" (выставляем второй параметр цикла — число ответов).


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеВ общем и в целом — правим номер столбца там, где используется переменная Верно (выставляем номер колонки число ответов плюс 3), там, где заголовок "верный ответ" (то же) и там, где в цикле крутится "вариант ответа" (выставляем второй параметр цикла — число ответов).

Автор - StoTisteg
Дата добавления - 07.05.2018 в 14:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Прошу помощи в изменении положения ячеек на листе (Макросы/Sub)
  • Страница 2 из 2
  • «
  • 1
  • 2
Поиск:

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