Страницы: 1
RSS
Нестандартная сортировка от А до Я с помощью макроса
 
Доброго дня всем. Нужна помощь в нестандартной сортировке, в прикрепленном файле на листе опбн вводится информация неблагополучных семей, на данный момент их более 100, нужно чтоб они в столбце В были по алфавиту, и вот тут заминка, дело в том что сперва вносится информация Родителя, затем детей. Напротив одного из родителей вводится адрес проживания семьи, дата договора и номер, и до следующего адреса в столбце F считается что это одна семья, в файле введены три семьи,  Ивановы, Арясовы, Бронины, нужно чтоб эти семьи были в порядке Арясовы, Бронины, Ивановы так же  данные в столбцах с С по V тоже переносились вместе с семьями. Данные в файле взяты из головы.
 
Цитата
написал:
Данные в файле взяты из головы.
удивительное совпадение - я макросы достаю от туда же)
положите этот
Код
Sub SortAndSaveFamily()
  Dim a, b, c&, i&, j&, k&, N, rg As Range
  Set rg = Intersect([4:1048576], ActiveSheet.UsedRange)
  c = ActiveSheet.UsedRange.Columns.Count + 3: a = rg
  Intersect(rg, [a:b,f:f]).Copy Cells(1, c)
  Cells(1, c).Resize(rg.Rows.Count, 3).RemoveDuplicates Columns:=3, Header:=xlYes
  If IsEmpty(Cells(3, c + 2)) Then Cells(3, c).Resize(1, 3).Delete
  ReDim N(1 To rg.Rows.Count, 1 To 1)
  Set rg = Cells(1, c).CurrentRegion: SortRangeBy rg, Array(2): b = rg
  Columns(c).Resize(, 3).Delete
  For i = 2 To UBound(b)
    j = b(i, 1) + 2: k = 1: N(b(i, 1) + k, 1) = i
    Do While IsEmpty(a(j, 6)) And (Not IsEmpty(a(j, 2)))
      k = k + 1: j = j + 1: N(b(i, 1) + k, 1) = i + k / 25
    Loop
  Next
  Cells(4, UBound(a, 2) + 1).Resize(UBound(N), 1) = N
  SortRangeBy Intersect([4:1048576], ActiveSheet.UsedRange), Array(UBound(a, 2) + 1)
  Columns(UBound(a, 2) + 1).Delete
  For i = 2 To UBound(N): N(i, 1) = i - 1: Next
  N(1, 1) = "№": Cells(4, 1).Resize(UBound(N), 1) = N
End Sub

Sub SortRangeBy(rg As Range, c, Optional Hd& = 1)
  Dim i&
  With rg.Parent.Sort
    .SortFields.Clear
    For i = LBound(c) To UBound(c)
      .SortFields.Add Key:=rg.Cells(1).Offset(Hd, Abs(c(i)) - 1).Resize( _
      rg.Rows.Count - Hd, 1), SortOn:=xlSortOnValues, Order:=IIf(c(i) > 0, _
      1, 2), DataOption:=xlSortNormal
    Next
    .SetRange rg: .Header = Hd: .MatchCase = False
    .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
End Sub
в стандартный модуль, выполните SortAndSaveFamily
Изменено: Ігор Гончаренко - 28.07.2022 15:14:14
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
написал:
удивительное совпадение - я макросы достаю от туда же)
Пардон, я про персональные данные имел ввиду)))
 
Ігор Гончаренко, спасибо за макрос, на этом файле работает, завтра проверю на основном файле.
 
Ігор Гончаренко, Добрый день, можно поправить макрос выше, чтоб он удалял не нужные строки? Может конечно лучше будет отдельным макросом, с добавлением столбца где можно ставить отметку и после запуска макроса, отмеченные строки удаляются.  Пробовал удалять полностью строку, но после удаления макрос сортирует не правильно.  
 
Может кто помочь с макросом? Очень нужно.
 
Цитата
Serega Ivanov написал:
поправить макрос выше, чтоб он удалял не нужные строки?
можно:
Код
Sub DeleteRows()
  Rows.Delete
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, он все удаляет, полностью.
Изменено: Serega Ivanov - 16.08.2022 15:32:30
 
вы считаете достаточно написать:
Цитата
Serega Ivanov написал:
чтоб он удалял не нужные строки
и теперь всем программистам во всем мире понятно что удалать?
в таком случае я считаю, что предложенный мною макрос вполне вам подойдет
редкое сочетание - два идиота в одной теме)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, Хорошо, попробую еще раз написать про свою проблему. В прикрепленном файле, к примеру в 6 строке Арясова Кристина Васильевна не нужна, удаляем полностью строку, добавляем ниже новую семью, запускаем макрос и получаем полную неразбериху. Такое же если не удалить 6 строку, а просто очистить содержимое строки. Два раза в месяц, комиссия кого то снимает, кого то ставит на контроль, список будет постоянно редактироваться.  
Изменено: Serega Ivanov - 16.08.2022 16:20:03
 
ладно, продолжим
1. подготовьте данные (поудаляйте лишнее, не очищайте строку от данных, а удаляйте ее целиком)
2. сделайте копию листа в тот же файл
3. сортируйте данные макросом, сохраните и выкладывайте сюда
4. напишите какие строки в отсортированном листе не на своих местах и где они должны быть по вашему
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, Подготовил файл, для наглядности изменил фон каждой семьи, на 1 листе данные трех семей, на 2 листе удалены строки с данными второй семьи и введены данные новой семьи, на 3 листе выполнен макрос сортировки семей и видно что данные последней введенной семьи не вместе.
 
1. после удаления "лишних" строк приводите в порядок № строк в данных (номера должны начинаться с 1 и идти подряд до последней строки с данными (пронумерованные пустые строки в конце таблицы - не важны)
2  процедуры
Sub SortAndSaveFamily()
и
Sub SortRangeBy(rg As Range, c, Optional Hd& = 1)
не нужно хранить в модуле каждого листа, достаточно 1 раз скопировать в стандартный модуль, а во всех листах - УДАЛИТЬ
3. в каждой группе (семье) должно быть минимум 2 человека
4. строку
 Intersect(rg, [a:b,f:f]).Copy Cells(1, c)
в процедуре Sub SortAndSaveFamily() лучше записать так
 Intersect(rg, [a:b,h:h]).Copy Cells(1, c)
чтобы избежать неправильной работы макроса в случае наличия одинаковых адресов, если одинаковые адреса исключены можно п.4 не выполнять
Изменено: Ігор Гончаренко - 18.08.2022 09:14:54
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Serega Ivanov, здравствуйте
Любая нестандартная сортировка - это либо создание своего списка (очень редко), либо приведение к стандартной сортировке — что-то убрать и/или добавить и/или вынести в отдельный столбец.
По описанию мало, что понятно, а открывать - нет желания.
Если бы вы написали "Вот у меня в ячейке написано Имя Отчество и Фамилия, а мне нужно по фамилии отсортировать", то вам бы сказали "вынесите фамилию в отдельный столбец и сортируйте по нему", а у вас "му … хрю …нужно то, не знаю, что. Это не то, то не это, как надо - не знаю, но нужно, чтобы ещё строки удалял…"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Ігор Гончаренко, Спасибо, теперь понятно как правильно делать чтоб макрос сортировал.  Одинаковые адреса редко, но встречаются.
Изменено: Serega Ivanov - 18.08.2022 09:42:51
 
Jack Famous, Добрый день, согласен, в пятом посту не понятно описал проблему, но в 12 посту вроде все понятно.
 
Цитата
Serega Ivanov: в пятом посту не понятно описал проблему, но в 12 посту вроде все понятно
а надо в 1ом
Открыл файл, 3 листа с цветными диапазонами. "Как есть" и "как надо" - не определено. Неинтересно.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, Самое главное что проблема решена)))
 
Jack Famous,
есть есть желание повозиться, то задача такая:
в таблице группы людей:
1-й - опекун (у него записаны Адрес, Дата и № договора)
и 1 или несколько подопечных у него, составляющих неразрывную группу
необходима стандартная сортировка по фамилиям опекунов, не стандартной ее делает то, что в отсортированном списке за опекуном должны следовать члены группы, как в исходных данных
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко: есть есть желание повозиться
желания нет  :D (тем более, ТС получил решение)
Спасибо за объяснение - так намного понятнее  ;)  :idea:
Изменено: Jack Famous - 18.08.2022 11:27:28
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
написал:
1. после удаления "лишних" строк приводите в порядок № строк в данных (номера должны начинаться с 1 и идти подряд до последней строки с данными (пронумерованные пустые строки в конце таблицы - не важны)
Добрый вечер, макросом было бы удобно это делать, так как список более 600 строк. Не поможете с ним?  с А5 по А999 нумерации будет достаточно.
 
Код
Sub SortAndSaveFamily()
  Dim a, b, c&, i&, j&, k&, N, rg As Range
  Set rg = Intersect([4:1048576], ActiveSheet.UsedRange)
  ReDim N(1 To rg.Rows.Count, 1 To 1)
  For i = 2 To UBound(N): N(i, 1) = i - 1: Next
  N(1, 1) = "№": Cells(4, 1).Resize(UBound(N), 1) = N
  c = ActiveSheet.UsedRange.Columns.Count + 3: a = rg
  Intersect(rg, [a:b,h:h]).Copy Cells(1, c)
  Cells(1, c).Resize(rg.Rows.Count, 3).RemoveDuplicates Columns:=3, Header:=xlYes
  If IsEmpty(Cells(3, c + 2)) Then Cells(3, c).Resize(1, 3).Delete
  ReDim N(1 To rg.Rows.Count, 1 To 1)
  Set rg = Cells(1, c).CurrentRegion: SortRangeBy rg, Array(2): b = rg
  Columns(c).Resize(, 3).Delete
  For i = 2 To UBound(b)
    j = b(i, 1) + 2: k = 1: N(b(i, 1) + k, 1) = i
    Do While IsEmpty(a(j, 6)) And (Not IsEmpty(a(j, 2)))
      k = k + 1: j = j + 1: N(b(i, 1) + k, 1) = i + k / 25
    Loop
  Next
  Cells(4, UBound(a, 2) + 1).Resize(UBound(N), 1) = N
  SortRangeBy Intersect([4:1048576], ActiveSheet.UsedRange), Array(UBound(a, 2) + 1)
  Columns(UBound(a, 2) + 1).Delete
  For i = 2 To UBound(N): N(i, 1) = i - 1: Next
  N(1, 1) = "№": Cells(4, 1).Resize(UBound(N), 1) = N
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, этот макрос исправляет нумерацию, но не сортирует, или он не должен сортировать?
 
Ещё вариант.
Код
Sub NonStandardSort()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    Dim yy As Long
    Dim xx As Long
    Dim rr As Range
    Dim arr As Variant
    Dim brr As Variant
    Dim crr As Variant
    With sh
        .ListObjects(1).Resize .ListObjects(1).Range.Rows(1)
    
        yy = .Cells(.Rows.Count, 2).End(xlUp).Row
        If yy <= 4 Then Exit Sub
        With .Cells(2, .Columns.Count).End(xlToLeft)
            xx = .Cells(1, .MergeArea.Columns.Count).Column
        End With
        Set rr = .Range(.Cells(5, 2), .Cells(yy, xx))
        arr = rr
        crr = rr.Columns(xx + 1).Resize(, 2)
        ReDim brr(1 To UBound(arr, 1), 1 To 2)
        brr(1, 1) = arr(1, 1)
        brr(1, 2) = 1
        For yy = 2 To UBound(arr, 1)
            If Not IsEmpty(arr(yy, 5)) Then
                brr(yy, 1) = arr(yy, 1)
            Else
                brr(yy, 1) = brr(yy - 1, 1)
            End If
            brr(yy, 2) = yy
        Next
        rr.Columns(xx + 1).Resize(, 2).Value = brr
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=rr.Columns(xx + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rr.Columns(xx + 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange rr.Resize(, xx + 2)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        rr.Columns(xx + 1).Resize(, 2).FormulaR1C1 = crr
        
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        .ListObjects(1).Resize .ListObjects(1).Range.Rows(1).Resize(yy - 4 + 1)
    End With
End Sub
 
Serega Ivanov, нумерация и удаления строк никак не связаны с сортировкой, о которой тема
Изменено: Jack Famous - 18.08.2022 17:07:24
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Всем спасибо, разобрался.
Изменено: Serega Ivanov - 18.08.2022 17:21:38
 
Цитата
Serega Ivanov написал:
тот макрос исправляет нумерацию, но не сортирует
покажите данные, которые он не отсортировал?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, на втором листе удалены двое из второй семьи и добавлена новая семья, при активации макроса исправляется нумерация, но последняя семья осталась на месте, а должна была встать на 10,11 строку
 
у них нету № договора
Володины входят в группу Иванова
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, Добрый день, точно, с прописанными номерами договоров все работает как надо, огромное Вам СПАСИБО.
Страницы: 1
Наверх