locked
Ranking values based on arrays (Excel VBA 2016) RRS feed

  • Question

  • Dear community,

    I am trying to create a procedure in Excel VBA to rank a group of values based on different arrays (Product Id).

    This can be a function or a sub.

    To be more specific, I have to rank the quotations of different suppliers for each product. My table is like this (I have more than 2000 rows):

    PRODUCT ID             SUPPLIER             PRICE             RANK

    Product1                    SupplierX               100$                  3

    Product1                    SupplierY               85$                    1

    Product1                    SupplierZ               90$                    2

    Product2                    SupplierX               1115$               3

    Product2                    SupplierZ               88$                    2

    Product2                    SupplierB               80$                   1

    Product3                    SupplierX               30$                   3

    Product3                    SupplierB               20$                    1

    Product3                    SupplierX               25$                    2

    I need to assign a rank to each price within the same array of products. 

    Can you pls explain me how to write the VBA code to create the product arrays and assign the ranking within such arrays?

    Lowest price gest rank no. 1 etc...

    Thanks in advance to all who will take the time to review this query!

    Nic

    Sunday, June 17, 2018 8:59 PM

All replies

  • Hello Nicola82,

    In fact you could easily do it using the sort function in Excel.

    Just Like.

    Its code looks like.

    Sub Macro1()
       ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=ActiveWorkbook.Worksheets("Sheet1").Columns(1) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=ActiveWorkbook.Worksheets("Sheet1").Columns(3) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange ActiveWorkbook.Worksheets("Sheet1").UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, June 18, 2018 2:52 AM
  • Hi Terry,

    There is a misunderstanding, actually I don't have the rank number in the rank column. I am looking for the funtion to find the ranking for the different product subcategories.

    The fucntion should rank the prices within each product type, and not on the overall range of prices.

    What you see in my table is the expected result on this fuction in the Rank column.

    Thanks again for the help.

    Nic

    Monday, June 18, 2018 10:05 AM
  • Hello Nicolar82,

    Try code like this,

    Sub FINALTEST()
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Dim objNewSheet As Worksheet
        ActiveWorkbook.Worksheets("Sheet1").Copy ActiveWorkbook.Worksheets(1)
        Set objNewSheet = ActiveWorkbook.Worksheets(1)
        objNewSheet.Name = "TemporaySheet"
        objNewSheet.Sort.SortFields.Clear
        objNewSheet.Sort.SortFields.Add Key:=objNewSheet.Columns(1) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        objNewSheet.Sort.SortFields.Add Key:=objNewSheet.Columns(3) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With objNewSheet.Sort
            .SetRange objNewSheet.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        lastRow = objNewSheet.Cells(objNewSheet.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lastRow
            If currentProduct <> objNewSheet.Cells(i, 1) Then
            currentProduct = objNewSheet.Cells(i, 1)
            currentIndex = 1
            Else
            currentIndex = currentIndex + 1
            End If
            objNewSheet.Cells(i, 4) = currentIndex
        Next i
        ActiveWorkbook.Worksheets("Sheet1").Cells(2, 4).Formula = "=SUMPRODUCT((A2=TemporaySheet!A:A)*(B2=TemporaySheet!B:B)*(C2=TemporaySheet!C:C),TemporaySheet!D:D)"
        ActiveWorkbook.Worksheets("Sheet1").Range("D2:D" & lastRow).FillDown
        ActiveWorkbook.Worksheets("Sheet1").Range("D2:D" & lastRow).Copy
        ActiveWorkbook.Worksheets("Sheet1").Range("D2:D" & lastRow).PasteSpecial xlPasteValues
        objNewSheet.Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, June 19, 2018 3:01 AM