Макрос Excel VBA

Question

Макрос Excel VBA

Олег))) Мыслитель (7037), на голосовании 1 месяц назад

Для нахождения заведения с максимальной выручкой с определенным направлением решил сначала проверять по направлению, затем сравнивать выручку. Если не соблюдаются условия - скрывать ряд. Не могу понять где ошибка, скрываются все строки.
Option Base 1
Sub Макс_выручка()
Dim direction As String
Dim vector(20) As Integer
Dim profit As Single
profit = 0
Dim i As Integer
i = 1
direction = InputBox("Введите направление")
For Each cell In ActiveSheet.UsedRange.Columns(1).Cells
If cell.Value = direction Then
vector(i) = i
Else
vector(i) = 0
End If
Next
i = 1
For Each cell In ActiveSheet.UsedRange.Columns(9).Cells
If Val(cell.Value) >= profit And vector(i) <> 0 Then
profit = Val(cell.Value)
Else
vector(i) = 0
End If
Next
i = 1
For Each cell In ActiveSheet.Range("2:21").Columns(1).Cells
If vector(i) = 0 Then cell.EntireRow.Hidden = True
Next

End Sub

Answer 1

Давайте добавим несколько новых функций в ваш код VBA для работы с тикетами в Excel. Мы можем расширить функциональность, добавив следующие функции:

СброситьСкрытыеСтроки
ОтобразитьТикеты
НайтиТикетПоИндексу
СохранитьДанныеВНовыйЛист
СоздатьОтчетОТикетах

 Option Base 1 
Sub Макс_выручка() 
    Dim direction As String 
    Dim vector(20) As Integer 
    Dim profit As Single 
    profit = 0 
    Dim i As Integer 
    Dim maxIndex As Integer 
    direction = InputBox("Введите направление") 
     
    ' Инициализация индекса 
    i = 1 
    ' Первый проход: проверка направления 
    For Each cell In ActiveSheet.UsedRange.Columns(1).Cells 
        If cell.Value = direction Then 
            vector(i) = i ' Сохраняем индекс строки 
        Else 
            vector(i) = 0 ' Устанавливаем 0, если направление не совпадает 
        End If 
        i = i + 1 ' Увеличиваем индекс 
    Next 
     
    ' Второй проход: поиск максимальной выручки 
    profit = 0 
    maxIndex = 0 
    For j = 1 To UBound(vector) 
        If vector(j) <> 0 Then 
            If Val(ActiveSheet.Cells(j, 9).Value) > profit Then 
                profit = Val(ActiveSheet.Cells(j, 9).Value) 
                maxIndex = j ' Сохраняем индекс строки с максимальной выручкой 
            End If 
        End If 
    Next j 
     
    ' Третий проход: скрытие строк 
    For j = 1 To UBound(vector) 
        If vector(j) = 0 Or j <> maxIndex Then 
            ActiveSheet.Rows(j).Hidden = True 
        End If 
    Next j 
End Sub 
Sub СброситьСкрытыеСтроки() 
    ActiveSheet.Rows.Hidden = False 
End Sub 
Sub ОтобразитьТикеты() 
    Dim i As Integer 
    Dim output As String 
    output = "Тикеты и их выручка:" & vbCrLf 
     
    For i = 1 To ActiveSheet.UsedRange.Rows.Count 
        output = output & "Направление: " & ActiveSheet.Cells(i, 1).Value & _ 
                 ", Выручка: " & ActiveSheet.Cells(i, 9).Value & vbCrLf 
    Next i 
    MsgBox output 
End Sub 
Sub НайтиТикетПоИндексу() 
    Dim index As Integer 
    index = InputBox("Введите индекс тикета") 
     
    If index > 0 And index <= ActiveSheet.UsedRange.Rows.Count Then 
        MsgBox "Направление: " & ActiveSheet.Cells(index, 1).Value & _ 
               ", Выручка: " & ActiveSheet.Cells(index, 9).Value 
    Else 
        MsgBox "Индекс вне диапазона." 
    End If 
End Sub 
Sub СохранитьДанныеВНовыйЛист() 
    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Worksheets.Add 
    ActiveSheet.UsedRange.Copy Destination:=ws.Range("A1") 
    MsgBox "Данные сохранены на новом листе." 
End Sub 
Sub СоздатьОтчетОТикетах() 
    Dim report As String 
    report = "Отчет о тикетах:" & vbCrLf 
     
    For i = 1 To ActiveSheet.UsedRange.Rows.Count 
        report = report & "Тикет " & i & ": Направление - " & ActiveSheet.Cells(i, 1).Value & _ 
                 ", Выручка - " & ActiveSheet.Cells(i, 9).Value & vbCrLf 
    Next i 
     
    MsgBox report 
End Sub