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

 

[Akuini]

Column E having formulas in it seems to be giving "Object Variable or With Block Variable not set" error.

You should check if Find method does find a match.

Set rngNames = rngValues.Find(j, , xlFormulas, xlWhole)

Why do you search in formula (you're using xlFormulas), shouldn’t it be xlValues?

So, perhaps:

For i = 1 To 10

j = Application.WorksheetFunction.Large(rngValues, i)
Worksheets("Clients").Cells(r, "C") = j

Set rngNames = rngValues.Find(j, , xlValues, xlWhole)
If Not rngNames Is Nothing Then
    Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)
End If
r = r + 1
Next i

 

[Pumper]

You should check if Find method does find a match.

Why do you search in formula (you're using xlFormulas), shouldn’t it be xlValues?

So, perhaps:

For i = 1 To 10

j = Application.WorksheetFunction.Large(rngValues, i)
Worksheets("Clients").Cells(r, "C") = j

Set rngNames = rngValues.Find(j, , xlValues, xlWhole)
If Not rngNames Is Nothing Then
    Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)
End If
r = r + 1
Next i

Thanks for your time Akuini.

I tried the above and seems to sort the issue of column E having formulas in there so yes xlValues is correct thanks very much.

Think it still doesn't like the column being in % format. Some cells for example have 20% and nothing is copied over.

Using For i = 1 to 10 is that just top ten results or needs to be a minimum size to qualify?

Strangely if i manually put in say 105% it copies over 100%??? is it rounding somehow?

Thanks again for any time spent on this, greatly appreciated

 

[Akuini]

Dim j As Long should be: Dim j As Double

 

[Pumper]

Dim j As Long should be: Dim j As Double

Yep you got it! thanks a lot.

Now if I can get the corresponding offset to copy over I am there...

Numbers look good which copied from column E, missing data from Column A

So must be this line?

Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)

 

[Akuini]

Try this:

For i = 1 To 10

    j = Application.WorksheetFunction.Large(rngValues, i)
    Worksheets("Clients").Cells(r, "C") = j
    
    Set rngNames = rngValues.Find(What:=Format(j, rngValues.NumberFormat), LookIn:=xlValues, lookAt:=xlWhole, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    
    If Not rngNames Is Nothing Then
        Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)
        r = r + 1
    End If

Next i

 

[Pumper]

Try this:

For i = 1 To 10

    j = Application.WorksheetFunction.Large(rngValues, i)
    Worksheets("Clients").Cells(r, "C") = j
   
    Set rngNames = rngValues.Find(What:=Format(j, rngValues.NumberFormat), LookIn:=xlValues, lookAt:=xlWhole, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
   
    If Not rngNames Is Nothing Then
        Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, -4)
        r = r + 1
    End If

Next i

I got all excited there, very nice! works perfectly unless there are multiple cells with the same value, numbers come back fine but looks to be taking the first corresponding match of all Duplicates

If no dupes works fine

Currently:
GDG 13%
GDG 13%
GDG 13%

Should be:
GDG 13%
ADF 13%
TRW 13%

 

[Akuini]

Try this:

Sub Top10x()

Dim rngValues As Range
Dim rngNames As Range
Dim i As Integer
Dim r As Integer
Dim j As Double
Dim lrow As Long
Dim l As String
Dim MyData As String
Dim c As Range, m As Range, x As Range
MyData = "States" & ".xlsm"

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

l = 0
j = 0
r = 3
Set m = rngValues.Offset(rngValues.Rows.Count - 1).Resize(1)
Set c = m

For i = 1 To 10
    Worksheets("Clients").Cells(r, "C") = j
    j = Application.WorksheetFunction.Large(rngValues, i)
        
    If j = k Then: Set x = c: Else: Set x = m
    
    Set rngNames = rngValues.Find(What:=Format(j, rngValues.NumberFormat), After:=x, LookIn:=xlValues, lookAt:=xlWhole, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not rngNames Is Nothing Then
            Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, 1)
            r = r + 1
            Set c = rngNames
            k = j
        End If
Next i

End Sub

 

[Pumper]

Try this:

Sub Top10x()

Dim rngValues As Range
Dim rngNames As Range
Dim i As Integer
Dim r As Integer
Dim j As Double
Dim lrow As Long
Dim l As String
Dim MyData As String
Dim c As Range, m As Range, x As Range
MyData = "States" & ".xlsm"

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

l = 0
j = 0
r = 3
Set m = rngValues.Offset(rngValues.Rows.Count - 1).Resize(1)
Set c = m

For i = 1 To 10
    Worksheets("Clients").Cells(r, "C") = j
    j = Application.WorksheetFunction.Large(rngValues, i)
       
    If j = k Then: Set x = c: Else: Set x = m
   
    Set rngNames = rngValues.Find(What:=Format(j, rngValues.NumberFormat), After:=x, LookIn:=xlValues, lookAt:=xlWhole, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not rngNames Is Nothing Then
            Worksheets("Clients").Cells(r, "B") = rngNames.Offset(, 1)
            r = r + 1
            Set c = rngNames
            k = j
        End If
Next i

End Sub

Thanks again for looking, very kind of you!

That now brings back duplicate offset details and not aligned properly

BTH is 23% not zero, CCX is 21% (miss aligned by 1 row it appears) and IFM appearing twice


BTH 0%
CCX 23%
CHL 21%
UNI 18%
DGL 17%
AMS 16%
SKO 15%
GDG 14%
IFM 13%
IFM 12%

The only thing i changed in your code was offset from 1 to -4

 

[Akuini]

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