VBA - сортировка ячеек, ссылающихся на MergeArea

Question

У меня проблема с кодом сортировки. Моя цель - отсортировать область по типу адреса. Каждый человек имеет несколько учетных записей, и его имя находится в объединенной области, которая существует до тех пор, пока существуют учетные записи. Таким образом, из "B3: B6" объединяется для первого.

Однако иногда эти люди имеют разные адреса под каждой учетной записью. Итак, я хотел бы отсортировать каждую область, в этом примере «C3: H6», по значениям в столбце E. Но когда я пробегаю построчно, она не выполняется.

КОД:

With NeedMail
    rwCnt = .Cells(Rows.Count, 1).End(xlUp).Row
    For y = 3 To rwCnt
        If .Cells(y, 2).MergeCells Then
            Set mrg = .Range(.Cells(y, 2).MergeArea.Address)
            Set srt = .Range(mrg.Offset(0, 1).Address & ":" & mrg.Offset(0, 6).Address)
            Set keyRng = .Range(mrg.Offset(0, 3).Address)
            cnt = .Cells(y, 2).MergeArea.Rows.Count
            Z = y + cnt - 1

            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=keyRng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange srt
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            mrg.UnMerge

        'More code to execute here

        End If
    Next y
End With

ОБРАЗЦЫ ДАННЫХ:

Заранее спасибо, я ломал голову, пытаясь понять, что не так?

Answer 1

При смещении mrg, например Set srt = .Range(mrg.Offset(0, 1)..., ваш новый диапазон смещения составляет всего 1 ряд. Так Resize количество строк с использованием cnt.

Кроме того, если у вас есть srt, вы можете просто использовать srt.Sort. Вот пересмотренный код, показывающий эту упрощенную сортировку.

Sub SortWhenMerged()
    Dim needMail As Worksheet
    Dim rwCnt As Long, y As Long, cnt As Long
    Dim mrg As Range, srt As Range, keyRng As Range

    Set needMail = ThisWorkbook.Worksheets("NeedMail")
    With needMail
        rwCnt = .Cells(.Rows.Count, 1).End(xlUp).row

        For y = 3 To rwCnt
            If .Cells(y, 2).MergeCells Then

                Set mrg = .Cells(y, 2).MergeArea
                cnt = mrg.Rows.Count

                Set srt = mrg.Offset(, 1).Resize(cnt, 6)
                Set keyRng = mrg.Offset(, 3).Resize(cnt)

                srt.Sort Key1:=keyRng, Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom, SortMethod:=xlPinYin

                mrg.UnMerge
            End If
        Next y
    End With

End Sub