Доброе утро,
Прошу помочь по макросу VBA Excel, необходимо проставить рейтинг по фильтру через сортировку, поочередный выбор из доступных фильтров далее сортировка от Я до А столбца E, F, G
Имеются данные в Excel Лист1, со столбцами от A до G, необходимо вначале поставить фильтр , далее по первому столбцу A выбрать первый из доступных далее сделать сортировку столбца E от Я до А, посчитать количество видимых строк и разделить на 3 (например: имеется 9 видимых строк нужно поделить на 3, получаем 3 соответственно проставляем 3 раза A, 3 раза B, 3 раза C ), далее полученное количество проставить в столбце H, вначале проставить полученное количество букву A далее столько же B, и столько же C. Также сделать это для столбца F и проставить также по столбцу I, и также сделать по F и проставить также по столбцу J. Далее уже выбрать следующий из имеющих из доступных фильтров и сделать также и все это повторить из всех имеющих доступных фильтров по столбцу A.
Приложил файл, сделал вручную на листе "Готово"
Пытался сделать через chatgpt, работает правда криво:
Скрытый текст |
|---|
| Код |
|---|
Sub ДинамическийФильтрД()
Dim Лист As Worksheet
Dim ДиапазонДанных As Range
Dim КолонкаФильтра As Range
Dim УникальныеЗначения As Collection
Dim ФильтрЗначение As Variant
Dim РаботающийДиапазон As Range
Dim Оценка As String
Dim Столбец As Long
Dim КоличествоСтрок As Long
Dim ОценкиСтолбец As Range
' Замените "Лист6" на имя вашего листа
Set Лист = Worksheets("Лист6")
' Замените "A1:G100" на диапазон вашего набора данных (включая столбцы E, F, G)
Set ДиапазонДанных = Лист.Range("A1:G200")
' Выберите колонку, по которой хотите установить фильтр
' В данном случае используется первая колонка
Set КолонкаФильтра = ДиапазонДанных.Columns(1)
' Создать коллекцию для уникальных значений
Set УникальныеЗначения = New Collection
' Заполнить коллекцию уникальными значениями из выбранной колонки
On Error Resume Next
For Each Значение In КолонкаФильтра.Cells
УникальныеЗначения.Add Значение.Value, CStr(Значение.Value)
Next Значение
On Error GoTo 0
' Пройтись по уникальным значениям и применить фильтры
For Each ФильтрЗначение In УникальныеЗначения
' Отфильтровать данные
ДиапазонДанных.AutoFilter Field:=1, Criteria1:=ФильтрЗначение
' Пройтись по столбцу E и выполнить сортировку
Столбец = 5 ' Столбец E
' Отсортировать столбец по убыванию
ДиапазонДанных.Sort key1:=ДиапазонДанных.Columns(Столбец), _
order1:=xlDescending, _
Header:=xlYes
' Проверить, что применен фильтр и колонка для оценок существует
If ДиапазонДанных.Rows.Count > 1 Then
' Проставить оценку A, B, C по количеству видимых строк
On Error Resume Next
Set РаботающийДиапазон = ДиапазонДанных.Offset(1, 0).Resize(ДиапазонДанных.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not РаботающийДиапазон Is Nothing Then
КоличествоСтрок = РаботающийДиапазон.Rows.Count
' Проставить оценки
If КоличествоСтрок > 0 Then
Dim КоличествоА As Long
Dim КоличествоБ As Long
Dim КоличествоС As Long
КоличествоА = КоличествоСтрок \ 3
КоличествоБ = КоличествоСтрок \ 3
КоличествоС = КоличествоСтрок - КоличествоА - КоличествоБ
' Определить столбец для оценок (H)
Set ОценкиСтолбец = ДиапазонДанных.Columns("H")
' Проставить оценки в соответствующий столбец
If Not ОценкиСтолбец Is Nothing Then
' Проставить оценку A
If КоличествоА > 0 Then
ОценкиСтолбец.Resize(КоличествоА).Value = "A"
End If
' Проставить оценку B
If КоличествоБ > 0 Then
ОценкиСтолбец.Offset(КоличествоА, 1).Resize(КоличествоБ).Value = "B"
End If
' Проставить оценку C
If КоличествоС > 0 Then
ОценкиСтолбец.Offset(КоличествоА + КоличествоБ, 1).Resize(КоличествоС).Value = "C"
End If
End If
End If
End If
End If
Next ФильтрЗначение
End Sub
|
|
