Copy Top Ten Values to another sheet that contain formulas

[Pumper]

Hi All,

I have a query that is almost identical to another post here that was solved but I still can't get it to work.

Copy Top 10 Values With Corresponding Names Into Another Sheet Excel VBA

Hi All; First of all, thanks again for your time and help in advance. Here I am with another issue which I’m failing to see where the problem is. Code below finds the highest 10 values in a range (column I) and copies them into another sheet. Part with the top 10 values and copying them is...

www.mrexcel.com

I am trying to copy the Top Ten values in column E Tab "Distribution" (this column contains formulas and is in % format) and corresponding value in column A (Text) to tab "Clients"

My code seems to have two problems
1) Column E having formulas in it seems to be giving "Object Variable or With Block Variable not set" error.
2) If I check and remove formulas and run looks like the number has to be greater than 1 to return it (I am after the top 10 numbers regardless of size).

Any help would be greatly appreciated!

Code:
Sub Top10()

Dim rngValues As Range
Dim rngNames As Range
Dim i As Integer
Dim r As Integer
Dim j As Long
Dim lrow As Long
Dim l As String
Dim MyData As String

MyData = "States" & ".xlsm"

Set rngValues = Workbooks(MyData).Sheets("Distribution").Range("E3:E500")

l = 0
j = 0
r = 3

For i = 1 To 10

j = Application.WorksheetFunction.Large(rngValues, i)
Set rngNames = rngValues.Find(j, , xlFormulas, xlWhole)
Worksheets("Clients").Cells(r, "C") = j
Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)
r = r + 1
Next i

End Sub

 

[Pumper]

Try this:
Do you have zero or negative number Range("E3:E500")?

Sub Top10y()

Dim rngValues As Range
Dim rngNames As Range
Dim i As Integer
Dim r As Integer
Dim j As Double
Dim MyData As String
Dim ary
Dim fm As Long

MyData = "States" & ".xlsm"

Set rngValues = Workbooks(MyData).Sheets("Distribution").Range("E3:E500")
ary = Application.Transpose(rngValues)
r = 3

For i = 1 To 10

    j = Application.WorksheetFunction.Large(ary, 1)
    Worksheets("Clients").Cells(r, "C") = j
        fm = Application.Match(j, ary, 0)
            If IsNumeric(fm) Then
                Worksheets("Clients").Cells(r, "B") = rngValues.Cells(fm, -4)
                r = r + 1
                ary(fm) = Empty
            End If

Next i

End Sub

Yes could could contain positive and negatives (the plan was once i get the "large" function to work I would then use that to also get "Small" to land next to these)

 

[Akuini]

Did you try the last code?

 

[Akuini]

Yes could could contain positive and negatives (the plan was once i get the "large" function to work I would then use that to also get "Small" to land next to these)

In that case, replace this:
ary(fm) = Empty
with:
ary(fm) = "x"

 

[Pumper]

In that case, replace this:
ary(fm) = Empty
with:
ary(fm) = "x"

yeah i tried (including the above amendment)

Getting Application-defined or object-defined error on this line

Worksheets("Clients").Cells(r, "B") = rngValues.Cells(fm, -4)

Brings back 1 number and no codes

 

[Akuini]

Worksheets("Clients").Cells(r, "B") = rngValues.Cells(fm, -4)

Sorry, it should be:
Worksheets("Clients").Cells(r, "B") = rngValues.Cells(fm, 1).Offset(, -4)

 

[Pumper]

Sorry, it should be:
Worksheets("Clients").Cells(r, "B") = rngValues.Cells(fm, 1).Offset(, -4)

YES!

Works perfectly!

Really appreciate your time and willingness to go over this multiple times.

Thanks so much

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.