CODEWITHSUNDEEP
excelvba
sheela
sheela

Reputation: 29

Moving Highest Values of a Column (and Its associated Columns) to Sheet 2

I have the following Data - Different Delivered Dates and No. of Items to be delivered on the respective day. But I want to move only the highest values of a column P2:P585 (And Associated columns A,B,C...O,P)

Date of Delivery No.of Products to be Delivered 17/03/2017 - 10 20/03/2017 - 2 21/03/2017 - 21 23/03/2017 - 4 24/03/2017 - 14 27/03/2017 - 12 28/03/2017 - 26 03/04/2017 - 10

For Example: on 17.03.2017, I have 94 Items after filtering. But I want to move only the Highest 10 Items to Sheet2. On 20.03.17, I have 85 Items, BuT I want move only Highest 2 values among 85 Items available in this day. This has to be done seriously for many dates till end of year and different qty on each date. So, my programm should contain the cell reference for Delivery date and Qty, So that I can use for N no. of datas.. Sorting is done already. Only the command to move given no. of qty for each delivery date is required. Some could help with ideas.?

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

Upvotes: 0

Views: 57

Answers (2)

user4039065
user4039065

Reputation:

This should do.

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

Upvotes: 1

Cyril
Cyril

Reputation: 6829

Assuming headers exist in row 1, we'll take a look at your top 10 items (sorted decended so highest value at the top):

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

Moves the data and then removes the, now, blank rows.

Upvotes: 1

Related Questions