Question

我有以下数据 - 不同的交付日期和当天交付的项目数。但是我想只移动P2列的最高值：P585（和相关列A，B，C ...... O，P）

交货日期 要交付的产品数量 2017/03/17 - 10 2017/03/20 - 2 2017/03/21 - 21 2017/03/23 - 4 2017/03/24 - 14 2017/03/27 - 12 2017/03/28 - 26 03/04/2017 - 10

例如：在17.03.2017，过滤后我有94个项目。但是我想把最高的10个项目移到Sheet2。在20.03.17，我有85个项目，我想在今天的85个项目中仅移动最高的2个值。必须认真对待许多日期，直到年底和每个日期的不同数量。所以，我的程序应该包含交付日期和数量的单元格引用，这样我就可以使用N no。数据..排序已经完成。只有命令移动否定。每个交货日期的数量是必需的。有些人可以帮助提出想法。？

Sub Filter_RPCALC()

'Calculation of Date Diff.
Range("N2").Formula = "=DAYS($A$590,D2)"
Range("N2").AutoFill Destination:=Range("N2:N585"), Type:=xlFillDefault

'Calculation of Rp
Dim var1 As Variant, var2 As Variant, var3 As Variant
Dim Rp As Variant
Dim i As Long
var1 = Range("M2:M585").Value
var2 = Range("02:0585").Value
var3 = Range("L2:L585").Value
Rp = var1
For i = LBound(Rp, 1) To UBound(Rp, 1)
    Rp(i, 1) = var1(i, 1) * var2(i, 1) + var3(i, 1)
Next i
Range("P2:P585").Value = Rp

'Filter the coils for Deliver Date
ActiveSheet.Range("$G$1:$G$585").AutoFilter Field:=1, Criteria1:="<" & CLng(Range("A590"))

'Sorting High to low of Rp
Range("A2:P585").Sort _
Key1:=Range("P2:P585"), Order1:=xlDescending

End Sub

Answer 1

假设第1行中存在标题，我们将查看您的前10个项目（排序在顶部降级为最高值）：

With Sheets("Source")
    .Range(.Rows(1),.Rows(11)).Cut Sheets("Destination").Cells(1,1)
    .Range(.Rows(2),.Rows(11)).Delete
End With

移动数据，然后删除现在的空白行。

Answer 2

应该这样做。

Sub Filter_RPCALC()
    Dim var1 As Variant, var2 As Variant, var3 As Variant, Rp As Variant
    Dim philters As Variant, p As Long, qtys As Variant
    Dim i As Long, f As Long, lr As Long, ws2 As Worksheet

    Set ws2 = ActiveWorkbook.Worksheets("sheet2")

    With Worksheets("sheet1")
        lr = Application.Max(.Cells(.Rows.Count, "L").End(xlUp).Row, _
                             .Cells(.Rows.Count, "M").End(xlUp).Row, _
                             .Cells(.Rows.Count, "O").End(xlUp).Row)
        'Calculation of Date Diff.
        .Range(.Cells(2, "N"), .Cells(lr, "N")).Formula = "=DAYS($A$590,D2)"

        'Calculation of Rp
        var1 = .Range("M2:M" & lr).Value
        var2 = .Range("O2:O" & lr).Value
        var3 = .Range("L2:L" & lr).Value
        Rp = var1
        For i = LBound(Rp, 1) To UBound(Rp, 1)
            Rp(i, 1) = var1(i, 1) * var2(i, 1) + var3(i, 1)
        Next i
        .Range("P2").Resize(UBound(Rp, 1), UBound(Rp, 2)) = Rp

        philters = Array(DateSerial(2017, 3, 17), 10, DateSerial(2017, 3, 20), 2, _
                         DateSerial(2017, 3, 21), 21, DateSerial(2017, 3, 23), 4, _
                         DateSerial(2017, 3, 24), 14, DateSerial(2017, 3, 27), 12, _
                         DateSerial(2017, 3, 28), 26, DateSerial(2017, 4, 3), 10)
        'Filter the coils for Deliver Date
        With .Range("A1:P" & lr)
            For p = LBound(philters) To UBound(philters) Step 2
                .AutoFilter Field:=7, Criteria1:=philters(p)
                ReDim qtys(philters(p + 1))
                For i = LBound(qtys) To UBound(qtys)
                    qtys(i) = Application.Aggregate(14, 7, .Columns(2), i + 1)
                Next i
                .AutoFilter Field:=2, Criteria1:=qtys, operation:=xlFilterValues
                With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                    .SpecialCells(xlCellTypeVisible).Copy _
                        Destination:=ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    .SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
            Next p

            .Cells.Sort Key1:=.Columns(16), Order1:=xlDescending, _
                       Orientation:=xlTopToBottom, Header:=xlYes

        End With
    End With

End Sub

将列的最高值（及其关联的列）移动到工作表2

2 个答案: