Страницы: 1
RSS
Автоматическая сортировка строк в зависимости от выбранного значения в ячейке каждой строки.
 
Добрый день.
Помогите сделать красивую, работающую таблицу)
Что есть:
2 столбца: "задача" (А) и "статус" (В)
В столбце (В) выпадающий список из значений: "Выполнена" / "Не выполнена".

Что надо:
Строки должны подниматься вверх, если выбрано значение "Не выполнена", соответственно, которые "Выполнены" должны опускаться вниз.

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

Пример такой таблицы во вложении.
Если не сложно, не могли бы описать работу каждой формулы\функции.

Буду очень благодарен за помощь!
Изменено: lumix153 - 16.05.2024 16:57:15
 
lumix153, формулами/функциями так не сделать, только макросом
 
Цитата
написал:
lumix153 , формулами/функциями так не сделать, только макросом
Понял, значит макросом. Но хочется понять всё логику построения макроса.
 
lumix153,
Цитата
Строки должны подниматься вверх, если выбрано значение "Не выполнена",
Вверх - это на верх таблицы в строку 2 или в конец работ со статусом "Не выполнена"?
Аналогично и для работ, которые "Выполнены" должны опускаться вниз.
 
Макрорекордер же пишет такое. Если канеш так нужно))
 
Цитата
написал:
Макрорекордер же пишет такое. Если канеш так нужно))

Прикрепленные файлы
Пример (2).xlsm  (18.36 КБ)
Добрый день.
К сожалению, не работает данный макрос.
Выдает ошибку:
 
Цитата
написал:
Вверх - это на верх таблицы в строку 2 или в конец работ со статусом "Не выполнена"?Аналогично и для работ, которые "Выполнены" должны опускаться вниз.
В строку 2.
Все строки, где в ячейке B(N) будет указан статус "Не выполнена" должны подниматься выше строк, где статус "Выполнена".  
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Columns(2), ActiveSheet.UsedRange) Is Nothing Then Exit Sub
    If ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 = 1 Then Exit Sub
    
    Dim cl As Range
    For Each cl In Intersect(Target, Columns(2), ActiveSheet.UsedRange).Cells
        If cl.Row > 1 Then
            Select Case cl.Value
            Case "выполнена"
                JobCell cl, True
            Case "не выполнена"
                JobCell cl, False
            End Select
        End If
    Next
End Sub

Private Sub JobCell(cl As Range, vypolnena As Boolean)
    Dim arr As Variant
    arr = Cells(1, 2).Resize(ActiveSheet.UsedRange.Rows.Count, 1).Value
    
    cl.EntireRow.Interior.Pattern = xlNone
    
    Dim ya As Long
    If vypolnena Then
        For ya = cl.Row + 1 To UBound(arr, 1)
            If arr(ya, 1) = "выполнена" Then
                Exit For
            End If
        Next
        If ya > cl.Row + 1 Then
            myMove cl, ya
        End If
        cl.EntireRow.Interior.Color = RGB(200, 255, 200)
    Else
        For ya = cl.Row - 1 To 2 Step -1
            If arr(ya, 1) = "не выполнена" Then
                Exit For
            End If
        Next
        If ya < cl.Row - 1 Then
            myMove cl, ya + 1
        End If
    End If
    
End Sub

Private Sub myMove(cl As Range, ya As Long)
    Cells(cl.Row, 1).Resize(1, 2).Cut
    Cells(ya, 1).Resize(1, 2).Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub

Изменено: МатросНаЗебре - 17.05.2024 10:19:24
 
Цитата
lumix153 написал:
Выдает ошибку:
попробуйте add2 заменить на add в этой строке   ActiveSheet.Sort.SortFields.Add2 Key:=Range("B2:B" & lngCounter) _
 
Цитата
написал:
КодPrivate Sub Worksheet_Change(ByVal Target As Range)
   If Intersect(Target, Columns(2), ActiveSheet.UsedRange) Is Nothing Then Exit Sub
   If ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 = 1 Then Exit Sub
   
   Dim cl As Range
   For Each cl In Intersect(Target, Columns(2), ActiveSheet.UsedRange).Cells
       If cl.Row > 1 Then
           Select Case cl.Value
           Case "выполнена"
               JobCell cl, True
           Case "не выполнена"
               JobCell cl, False
           End Select
       End If
   Next
End Sub

Private Sub JobCell(cl As Range, vypolnena As Boolean)
   Dim arr As Variant
   arr = Cells(1, 2).Resize(ActiveSheet.UsedRange.Rows.Count, 1).Value
   
   cl.EntireRow.Interior.Pattern = xlNone
   
   Dim ya As Long
   If vypolnena Then
       For ya = cl.Row + 1 To UBound(arr, 1)
           If arr(ya, 1) = "выполнена" Then
               Exit For
           End If
       Next
       If ya > cl.Row + 1 Then
           myMove cl, ya
       End If
       cl.EntireRow.Interior.Color = RGB(200, 255, 200)
   Else
       For ya = cl.Row - 1 To 2 Step -1
           If arr(ya, 1) = "не выполнена" Then
               Exit For
           End If
       Next
       If ya < cl.Row - 1 Then
           myMove cl, ya + 1
       End If
   End If
   
End Sub

Private Sub myMove(cl As Range, ya As Long)
   Cells(cl.Row, 1).Resize(1, 2).Cut
   Cells(ya, 1).Resize(1, 2).Insert Shift:=xlDown
   Application.CutCopyMode = False
End Sub
Спасибо большое! Код рабочий.
А в какой строке кода и как поменять, чтобы задачи со статусом "не выполнена" поднимались на самый верх, поверх других "Не выполненных"?
И еще. В данной таблице все 2 столбца.
Что добавить в код, чтобы поднимались все ячейки одной строки, у которой статус "Не выполнена".  
Изменено: lumix153 - 17.05.2024 10:37:24
 
Код
Option Explicit
'v2
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Columns(2), ActiveSheet.UsedRange) Is Nothing Then Exit Sub
    If ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 = 1 Then Exit Sub
    
    Dim cl As Range
    For Each cl In Intersect(Target, Columns(2), ActiveSheet.UsedRange).Cells
        If cl.Row > 1 Then
            Select Case cl.Value
            Case "выполнена"
                JobCell cl, True
            Case "не выполнена"
                JobCell cl, False
            End Select
        End If
    Next
End Sub

Private Sub JobCell(cl As Range, vypolnena As Boolean)
    Dim arr As Variant
    arr = Cells(1, 2).Resize(ActiveSheet.UsedRange.Rows.Count, 1).Value
    
    cl.EntireRow.Interior.Pattern = xlNone
    
    Dim ya As Long
    If vypolnena Then
        For ya = cl.Row + 1 To UBound(arr, 1)
            If arr(ya, 1) = "выполнена" Then
                Exit For
            End If
        Next
        If ya > cl.Row + 1 Then
            myMove cl, ya
        End If
        cl.EntireRow.Interior.Color = RGB(200, 255, 200)
    Else
        For ya = 2 To cl.Row
            If arr(ya, 1) = "не выполнена" Then
                Exit For
            End If
        Next
        If ya = cl.Row Then ya = 2
        If ya < cl.Row Then
            myMove cl, ya
        End If
    End If
    
End Sub

Private Sub myMove(cl As Range, ya As Long)
    Cells(cl.Row, 1).Resize(1, 2).Cut
    Cells(ya, 1).Resize(1, 2).Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub
 
Цитата
написал:
Что добавить в код, чтобы поднимались все ячейки одной строки, у которой статус "Не выполнена".  
Код
Resize(1, 2) заменить на EntireRow
Но там справа мешает диапазон H3:H4.
 
Цитата
написал:
КодResize(1, 2) заменить на EntireRowНо там справа мешает диапазон H3:H4.
Да, сработало.
Ещё один нюанс:
Если этой таблицей будет пользоваться другой человек. Ему надо будет обязательно включать режим разработчика?
Или можно как-то сделать это автоматически? Чтобы человек просто открывал файл таблицы и код успешно работал на автомате.  
 
Это типа "режим берсерка" только в программировании?  :D
Режим разработчика включать не надо, что бы это ни значило.
А вот разрешить макрос придётся.
 
Цитата
написал:
Это типа "режим берсерка" только в программировании?   Режим разработчика включать не надо, что бы это ни значило.А вот разрешить макрос придётс
Получается так)
Просто я сейчас открыл файл, но код уже не работал. И из Visual Basic код пропал.
А хочется, чтобы при открытии файла, код работал автоматически)
 
Цитата
написал:
из Visual Basic код пропал.
Файл сохранили с расширением .xlsx?
 
Цитата
написал:
Файл сохранили с расширением .xlsx?
Изначально нет.
Но разобрался, что нужно сохранять в формате .xlsm
Спасибо! Сейчас вроде как всё работает.

Желаю вам дальнейших успехов в ваших способностях)
Страницы: 1
Наверх