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

Вход

Регистрация

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

 

= Мир MS Excel/Создание конкурсного списка средствами VBA - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание конкурсного списка средствами VBA (Макросы/Sub)
Создание конкурсного списка средствами VBA
Sashagor1982 Дата: Воскресенье, 28.11.2021, 13:26 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 238
Репутация: 4 ±
Замечаний: 0% ±

Excel 2007
Подскажите как средствами VBA можно решить следующую задачу. Имеется список абитуриентов, в котором имеется заявленная специальность и результаты сдачи ЕГЭ, необходимо сформировать конкурсный список по указанной специальности и соответственно выстроить абитуриентов в порядке суммы баллов ЕГЭ по убыванию.
Исходные Данные:

Конкурсный список по специальности ИТ
К сообщению приложен файл: 3139043.xlsx(16.8 Kb)


Сообщение отредактировал Sashagor1982 - Воскресенье, 28.11.2021, 13:34
 
Ответить
СообщениеПодскажите как средствами VBA можно решить следующую задачу. Имеется список абитуриентов, в котором имеется заявленная специальность и результаты сдачи ЕГЭ, необходимо сформировать конкурсный список по указанной специальности и соответственно выстроить абитуриентов в порядке суммы баллов ЕГЭ по убыванию.
Исходные Данные:

Конкурсный список по специальности ИТ

Автор - Sashagor1982
Дата добавления - 28.11.2021 в 13:26
jun Дата: Воскресенье, 28.11.2021, 15:54 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 8 ±
Замечаний: 0% ±

Посмотрите код:

[vba]
Код
Sub Преобразование()
Dim i, myRange As Range, LastRow As Long, LastCol As Long
Dim shtTarget As Worksheet
ThisWorkbook.Worksheets("Лист1").Activate ' активируем лист с фильтром (с которого забираем значения)
With ActiveSheet
.ListObjects("Таблица1").Range.AutoFilter Field:=5, Criteria1:= _
        "ИТ"
LastRow = Cells(1, 1).End(xlDown).Row
LastCol = Cells(1, 1).End(xlToRight).Column
Set myRange = .UsedRange.SpecialCells(xlCellTypeVisible)

Set shtTarget = Sheets.Add(after:=Sheets(Sheets.Count))
shtTarget.Name = "Список по IT"

myRange.Copy
shtTarget.Cells(1, 1).PasteSpecial xlValues
shtTarget.Sort.SortFields.Add _
Key:=Range("I2:I" & LastRow), SortOn:=xlSortOnValues, Order _
        :=xlDescending, DataOption:=xlSortNormal
    With shtTarget.Sort
        .SetRange Range(Cells(1, 1), Cells(LastRow, LastCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
shtTarget.ListObjects.Add(xlSrcRange, shtTarget.UsedRange, , xlYes).Name = _
        "РеётингПо_IT"
.ListObjects("Таблица1").Range.AutoFilter Field:=5
End With
End Sub
[/vba]
К сообщению приложен файл: _3139043.xlsb(24.7 Kb)


Сообщение отредактировал jun - Воскресенье, 28.11.2021, 16:03
 
Ответить
СообщениеПосмотрите код:

[vba]
Код
Sub Преобразование()
Dim i, myRange As Range, LastRow As Long, LastCol As Long
Dim shtTarget As Worksheet
ThisWorkbook.Worksheets("Лист1").Activate ' активируем лист с фильтром (с которого забираем значения)
With ActiveSheet
.ListObjects("Таблица1").Range.AutoFilter Field:=5, Criteria1:= _
        "ИТ"
LastRow = Cells(1, 1).End(xlDown).Row
LastCol = Cells(1, 1).End(xlToRight).Column
Set myRange = .UsedRange.SpecialCells(xlCellTypeVisible)

Set shtTarget = Sheets.Add(after:=Sheets(Sheets.Count))
shtTarget.Name = "Список по IT"

myRange.Copy
shtTarget.Cells(1, 1).PasteSpecial xlValues
shtTarget.Sort.SortFields.Add _
Key:=Range("I2:I" & LastRow), SortOn:=xlSortOnValues, Order _
        :=xlDescending, DataOption:=xlSortNormal
    With shtTarget.Sort
        .SetRange Range(Cells(1, 1), Cells(LastRow, LastCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
shtTarget.ListObjects.Add(xlSrcRange, shtTarget.UsedRange, , xlYes).Name = _
        "РеётингПо_IT"
.ListObjects("Таблица1").Range.AutoFilter Field:=5
End With
End Sub
[/vba]

Автор - jun
Дата добавления - 28.11.2021 в 15:54
MikeVol Дата: Воскресенье, 28.11.2021, 19:52 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 16 ±
Замечаний: 0% ±

Excel 2019
Sashagor1982, Доброго времени суток. А в вашей перед этой теме помогающему вам ответить не вариант?


Ученик - Наблюдатель. Учиться Никогда не поздно.
 
Ответить
СообщениеSashagor1982, Доброго времени суток. А в вашей перед этой теме помогающему вам ответить не вариант?

Автор - MikeVol
Дата добавления - 28.11.2021 в 19:52
bmv98rus Дата: Воскресенье, 28.11.2021, 20:22 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3777
Репутация: 665 ±
Замечаний: 0% ±

Excel 2013/2016
А в вашей перед этой теме помогающему вам ответить не вариант?
Я б на вашем месте с такими комментами еще сообщений 100-200 полезных повременил. Да и в целом, можно подумать, что нет ответа на ваше выстраданное чудо решение.

А просто сводную не хотели использовать?
К сообщению приложен файл: example2506.xlsx(23.3 Kb)


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

Сообщение отредактировал bmv98rus - Воскресенье, 28.11.2021, 20:43
 
Ответить
Сообщение
А в вашей перед этой теме помогающему вам ответить не вариант?
Я б на вашем месте с такими комментами еще сообщений 100-200 полезных повременил. Да и в целом, можно подумать, что нет ответа на ваше выстраданное чудо решение.

А просто сводную не хотели использовать?

Автор - bmv98rus
Дата добавления - 28.11.2021 в 20:22
Sashagor1982 Дата: Воскресенье, 28.11.2021, 21:17 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 238
Репутация: 4 ±
Замечаний: 0% ±

Excel 2007
Тут важно, что бы решение было чисто программным)))
 
Ответить
СообщениеТут важно, что бы решение было чисто программным)))

Автор - Sashagor1982
Дата добавления - 28.11.2021 в 21:17
MikeVol Дата: Воскресенье, 28.11.2021, 21:59 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 16 ±
Замечаний: 0% ±

Excel 2019
bmv98rus, та я-ж не претендую.
на ваше выстраданное чудо решение
ну-ну. Помогающий старался а ответ от ТС-а так и не был дан. И только после моего поста был дан ответ.
Да и вообще bmv98rus, это не моё решение задачи было. И если проследить темы от данного ТС то они скорее попахивают Комплексной Задачей. Смотрите тему а потом давайте такие Ваши Аналитические высказывания. Не в Обиду.


Ученик - Наблюдатель. Учиться Никогда не поздно.
 
Ответить
Сообщениеbmv98rus, та я-ж не претендую.
на ваше выстраданное чудо решение
ну-ну. Помогающий старался а ответ от ТС-а так и не был дан. И только после моего поста был дан ответ.
Да и вообще bmv98rus, это не моё решение задачи было. И если проследить темы от данного ТС то они скорее попахивают Комплексной Задачей. Смотрите тему а потом давайте такие Ваши Аналитические высказывания. Не в Обиду.

Автор - MikeVol
Дата добавления - 28.11.2021 в 21:59
bmv98rus Дата: Воскресенье, 28.11.2021, 22:21 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3777
Репутация: 665 ±
Замечаний: 0% ±

Excel 2013/2016
[offtop] MikeVol, вот я и говорю, не рановато ли вы аналитику по ответам на форуме начали проводить. Для этого есть модераторы и администраторы, которые следят за нарушениями.
И если проследить темы от данного ТС то они скорее попахивают Комплексной Задачей.
И что?
[/offtop]


Замечательный Временно просто медведь , процентов на 20.
 
Ответить
Сообщение[offtop] MikeVol, вот я и говорю, не рановато ли вы аналитику по ответам на форуме начали проводить. Для этого есть модераторы и администраторы, которые следят за нарушениями.
И если проследить темы от данного ТС то они скорее попахивают Комплексной Задачей.
И что?
[/offtop]

Автор - bmv98rus
Дата добавления - 28.11.2021 в 22:21
MikeVol Дата: Воскресенье, 28.11.2021, 22:32 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 16 ±
Замечаний: 0% ±

Excel 2019
[offtop] bmv98rus, да так, вам же виднее. Не спорю.


Ученик - Наблюдатель. Учиться Никогда не поздно.
 
Ответить
Сообщение[offtop] bmv98rus, да так, вам же виднее. Не спорю.

Автор - MikeVol
Дата добавления - 28.11.2021 в 22:32
jun Дата: Воскресенье, 28.11.2021, 22:44 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 8 ±
Замечаний: 0% ±

Тут важно, что бы решение было чисто программным)))

посмотрите - программное решение:
[vba]
Код
Sub Список()
    Dim arr, newArr(), sht As Worksheet
    Dim i, k, c, m
    arr = Worksheets("Лист1").Cells(1, 1).CurrentRegion
     c = FindValues(arr)
     m = 1
    ReDim newArr(1 To c, 1 To UBound(arr, 2))
    For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, 5) = "ИТ" Then
            For k = LBound(arr, 2) To UBound(arr, 2)
                newArr(m, k) = arr(i, k)
            Next k
    m = m + 1
    End If
    Next i
    newArr = CoolSort(newArr, 9)
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = "СписокПо_IT"
    sht.Cells(1, 1).Resize(1, UBound(arr, 2)) = arr
    sht.Cells(2, 1).Resize(UBound(newArr, 1), UBound(newArr, 2)) = newArr
End Sub

Private Function FindValues(arr)
    Dim i, k
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 5) = "ИТ" Then k = k + 1
    Next i
FindValues = k
End Function

[/vba]
Сортировки (вставлять вместе с макросом):
- моя
[vba]
Код
Function sort(arr, N)
Dim i, k, m, temp

arr = ActiveSheet.Cells(1, 1).CurrentRegion

For i = LBound(arr, 1) To UBound(arr, 1) - 1
    For k = i + 1 To UBound(arr, 1)
        If arr(i, N) > arr(k, N) Then
            For m = LBound(arr, 2) To UBound(arr, 2)
                temp = arr(k, m)
                arr(k, m) = arr(i, m)
                arr(i, m) = temp
            Next m
        End If
    Next k
Next i
[/vba]
- с сайта https://excelvba.ru/code/SortArray
[vba]
Код
' код ниже взят с сайта https://excelvba.ru/code/SortArray
Function CoolSort(SourceArr As Variant, ByVal N As Integer) As Variant
    ' сортировка двумерного массива по столбцу N
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, N)) > Val(SourceArr(iCount + 1, N)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function
[/vba]


Сообщение отредактировал jun - Воскресенье, 28.11.2021, 23:53
 
Ответить
Сообщение
Тут важно, что бы решение было чисто программным)))

посмотрите - программное решение:
[vba]
Код
Sub Список()
    Dim arr, newArr(), sht As Worksheet
    Dim i, k, c, m
    arr = Worksheets("Лист1").Cells(1, 1).CurrentRegion
     c = FindValues(arr)
     m = 1
    ReDim newArr(1 To c, 1 To UBound(arr, 2))
    For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, 5) = "ИТ" Then
            For k = LBound(arr, 2) To UBound(arr, 2)
                newArr(m, k) = arr(i, k)
            Next k
    m = m + 1
    End If
    Next i
    newArr = CoolSort(newArr, 9)
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = "СписокПо_IT"
    sht.Cells(1, 1).Resize(1, UBound(arr, 2)) = arr
    sht.Cells(2, 1).Resize(UBound(newArr, 1), UBound(newArr, 2)) = newArr
End Sub

Private Function FindValues(arr)
    Dim i, k
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 5) = "ИТ" Then k = k + 1
    Next i
FindValues = k
End Function

[/vba]
Сортировки (вставлять вместе с макросом):
- моя
[vba]
Код
Function sort(arr, N)
Dim i, k, m, temp

arr = ActiveSheet.Cells(1, 1).CurrentRegion

For i = LBound(arr, 1) To UBound(arr, 1) - 1
    For k = i + 1 To UBound(arr, 1)
        If arr(i, N) > arr(k, N) Then
            For m = LBound(arr, 2) To UBound(arr, 2)
                temp = arr(k, m)
                arr(k, m) = arr(i, m)
                arr(i, m) = temp
            Next m
        End If
    Next k
Next i
[/vba]
- с сайта https://excelvba.ru/code/SortArray
[vba]
Код
' код ниже взят с сайта https://excelvba.ru/code/SortArray
Function CoolSort(SourceArr As Variant, ByVal N As Integer) As Variant
    ' сортировка двумерного массива по столбцу N
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, N)) > Val(SourceArr(iCount + 1, N)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function
[/vba]

Автор - jun
Дата добавления - 28.11.2021 в 22:44
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание конкурсного списка средствами VBA (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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