Случайно перемешать строки на основе значения столбца

Question

У меня есть лист с 8 столбцами и около 300 строк.Один из столбцов («D») помечен как «Сгруппированный», который имеет значение «Да» или «Нет».«Сгруппированные» строки, то есть те строки со значением «Да» в столбце «Сгруппированные», как правило, состоят из 2-5 строк и появляются между строками «Нет».Используя VBA, я хочу перетасовать порядок строк, начиная со строки 2 до последней использованной строки, но с соблюдением следующих условий:

1. Сгруппированные строки не могут быть перетасованы.
2. ПозицияСгруппированные строки могут измениться, например, сгруппированные строки в строке 50-53 можно переместить в строку 1-4, а сгруппированные строки в строке 100-103 можно переместить в строку 150-153.

До:

После:

Я попытался присвоить случайное значение строке в новом столбце и применить сортировку на основе этого нового столбца, но не могу выполнить условия.Я пытался поменять строки, используя выборки, т. Е. «Отфильтровать» сгруппированные строки, но они все равно оказались перемешанными.

Answer 1

Этот макрос должен работать для вас:

<code>Sub Shuffle()
Dim Lrow As Long
Dim AR1() As Variant
Dim AR2() As Variant
Dim R1 As Range
Dim Num As Long
Dim AA As Integer
Dim BB As Long
Dim CC As Integer
Dim DD As Integer
Lrow = ActiveSheet.Range("A200000").End(xlUp).Row
Set R1 = ActiveSheet.Range("A2:H" & Lrow)
ReDim AR1(1 To (Lrow - 1), 1 To 8)
ReDim AR2(1 To (Lrow - 1), 1 To 8)
AR1 = R1
For BB = LBound(AR1, 1) To UBound(AR1, 1)
    AA = 1
    If AR1(BB, 3) = "Yes" Then
        Num = BB
        Do Until Num = 0
            Num = Num + 1
            If Num > UBound(AR1, 1) Then
                Num = 0
            Else
                If AR1(Num, 3) = "No" Then
                    Num = 0
                Else
                    AA = AA + 1
                End If
            End If
        Loop
        Do Until Num <> 0
            Num = Int((UBound(AR1, 1) - LBound(AR1, 1) + 1) * Rnd + LBound(AR1, 1))
            For CC = 1 To AA
                If (Num + CC - 1) > UBound(AR1, 1) Then
                    Num = 0
                    Exit For
                Else
                    If AR2(Num + CC - 1, 3) <> "" Then
                        Num = 0
                        Exit For
                    End If
                End If
            Next CC
        Loop
        For CC = 1 To AA
            For DD = 1 To 8
                AR2(Num + CC - 1, DD) = AR1(BB + CC - 1, DD)
            Next DD
            AR1(BB + CC - 1, 3) = ""
        Next CC
    End If
Next BB
For BB = LBound(AR1, 1) To UBound(AR1, 1)
    If AR1(BB, 3) <> "" Then
        AA = 0
        Num = 0
        Do Until Num <> 0
            Num = Int((UBound(AR1, 1) - LBound(AR1, 1) + 1) * Rnd + LBound(AR1, 1))
            If AR2(Num, 3) = "" Then
                For DD = 1 To 8
                    AR2(Num, DD) = AR1(BB, DD)
                Next DD
                AR1(BB, 3) = ""
            Else
                Num = 0
                AA = AA + 1
            End If
            If AA > 10 Then
                For CC = LBound(AR1, 1) To UBound(AR1, 1)
                    If AR2(CC, 3) = "" Then
                        For DD = 1 To 8
                            AR2(CC, DD) = AR1(BB, DD)
                        Next DD
                        AR1(BB, 3) = ""
                        Num = CC
                        Exit For
                    End If
                Next CC
            End If
        Loop
    End If
Next BB
R1 = AR2
End Sub
</code>

удачи