Question

我想知道是否有可能使用VBA根据单元格的颜色将一系列单元格移动到列的底部。这是我需要的一个例子。正确的图像是最终结果，我不需要复制它。

enter image description here

这就是我所做的。

Sub Move_Down()

    Dim lr As Long, lr2 As Long, r As Long, count As Long

    lr = Sheets("Test").Cells(Rows.count, "A").End(xlUp).Row

    Set ws = Sheets("Test")
    count = 1

    'copy the cells with a color
    For r = 2 To lr
        If Sheets("Test").Cells(r, 1).Interior.ColorIndex = 36 Then
            Sheets("Test").Cells(count, 6).Value = Sheets("Test").Cells(r, 1).Value
            Sheets("Test").Cells(count, 7).Value = Sheets("Test").Cells(r, 2).Value
            Sheets("Test").Cells(count, 8).Value = Sheets("Test").Cells(r, 3).Value
            count = count + 1
        End If
    Next r

    'delete cells with color
    For r = 2 To lr
        If Sheets("Test").Cells(r, 1).Interior.ColorIndex = 36 Then
            Sheets("Test").Cells(r, 1) = Empty
            Sheets("Test").Cells(r, 2) = Empty
            Sheets("Test").Cells(r, 3) = Empty
        End If
    Next r

    'paste colored cells at bottom
    lr2 = Sheets("Test").Cells(Rows.count, "F").End(xlUp).Row

    For r = 1 To lr2
        Sheets("Test").Cells(lr + r, 1) = Sheets("Test").Cells(r, 6)
        Sheets("Test").Cells(lr + r, 2) = Sheets("Test").Cells(r, 7)
        Sheets("Test").Cells(lr + r, 3) = Sheets("Test").Cells(r, 8)
        Sheets("Test").Cells(lr + r, 1).Interior.ColorIndex = 36
        Sheets("Test").Cells(r, 6) = Empty
        Sheets("Test").Cells(r, 7) = Empty
        Sheets("Test").Cells(r, 8) = Empty
    Next r

    'delete empty rows

    lastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row

    Set rng = ws.Range("A1:A" & lastRow)
    With rng
        .AutoFilter Field:=1, Criteria1:=Empty
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ws.AutoFilterMode = False

End Sub

它做了我需要的，但我想知道是否有更简单的方法来做到这一点。

我需要它不删除空行，因为我在这些行中有其他数据。

Answer 1

最后这是我正在使用的代码。比我发布的那个更简单。

Columns("A:C").Select
ActiveWorkbook.Worksheets("Test").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Test").Sort.SortFields.Add(Range("A2:A8"), _
    xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(255, _
    255, 153)
With ActiveWorkbook.Worksheets("Test").Sort
    .SetRange Range("A1:C8")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("A2").Select

Answer 2

此代码应该完成这项工作：

Sub MoveColorsToBottom()
    Dim rngAll As Range, rngCell As Range, rngTarget As Range
    Dim intCols As Integer
    Dim strAddress As String

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Set rngAll = [A2:B7] 'insert your range without headers here

    intCols = rngAll.Columns.Count

    Set rngTarget = rngAll.Resize(1, 1).Offset(rngAll.Rows.Count)

    For Each rngCell In rngAll.Resize(, 1)
        If rngCell.Interior.Color <> RGB(255, 255, 255) Then 'this excludes all white cells
            strAddress = rngCell.Resize(, intCols).Address
            rngCell.Resize(1, intCols).Cut rngTarget.Offset(1)
            Set rngTarget = rngTarget.Offset(1)
            Range(strAddress).Delete xlShiftUp
        End If
    Next

    rngAll.Offset(rngAll.Rows.Count).Resize(1).Delete xlShiftUp

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

在列表底部移动范围

2 个答案: