TOP 10 copy and paste with VBA

[NBZ85]

Dear Experts,

I tried to create a macro and I am really stuck at a point. I looked around in the forum but I couldn't find the solution so now I would like to ask your help.

My issue is the same like in the file attached:
TOP 10 copy and paste.xlsm

On the Data sheet you can see three Columns. The values are sorted ascending in column C like in my original file.
I would like to do with VBA the following:
TOP10 >0:
- Filter "a" in the Type column (column B).
- Choose the 10 biggest (so above 0) values from Value column (column C).
- Copy and paste these rows to the Paste sheet from row 3 to row 12 (it is very important to me to copy and paste the entire rows).

TOP10 >0:
- Filter "a" in the Type column (column B).
- Choose the 10 smallest values (so below 0) from Value column (column C).
- Copy and paste these rows to the Paste sheet from row 18 to row 27 (it is very important to me to copy and paste the entire rows).

So as you can see basically the macro should do the same: first copy and paste the 10 biggest values with "a" filter and then copy and paste the 10 smallest with the same settings. With this I could easily get the TOP10 values in both direction from 0 and I can do my further analysis.

I hope you can help!

Thank you very much for your efforts!

[tigeravatar]

NBZ85,

Using your example file, something like this should work for you:

Sub tgr()
    
    Const sType As String = "a"
    
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim arrLarge As Variant
    Dim arrSmall As Variant
    
    Set wsData = Sheets("Data")
    Set wsDest = Sheets("Paste")
    
    With wsData.Range("C2", wsData.Cells(Rows.Count, "C").End(xlUp))
        arrLarge = Application.Transpose(Evaluate("INDEX(TEXT(LARGE(INDEX(('" & wsData.Name & "'!" & .Offset(, -1).Address & "=""" & sType & """)*'" & wsData.Name & "'!" & .Address & ",),ROW(1:10)),""" & .Cells(1).NumberFormat & """),)"))
        arrSmall = Application.Transpose(Evaluate("INDEX(TEXT(SMALL(INDEX(('" & wsData.Name & "'!" & .Offset(, -1).Address & "=""" & sType & """)*'" & wsData.Name & "'!" & .Address & ",),ROW(1:10)),""" & .Cells(1).NumberFormat & """),)"))
    End With
    
    With wsData.UsedRange
        .AutoFilter 2, sType
        .AutoFilter 3, arrLarge, xlFilterValues
        .Offset(1).EntireRow.Copy wsDest.Range("A3")
        .AutoFilter 3, arrSmall, xlFilterValues
        .Offset(1).EntireRow.Copy wsDest.Range("A18")
        .AutoFilter
    End With
    
    wsDest.Range("A2:C12").Sort wsDest.Range("C3"), xlDescending, Header:=xlGuess
    wsDest.Range("A17:C27").Sort wsDest.Range("C18"), xlAscending, Header:=xlGuess
    
    Set wsData = Nothing
    Set wsDest = Nothing
    If IsArray(arrLarge) Then Erase arrLarge
    If IsArray(arrSmall) Then Erase arrSmall
    
End Sub

[NBZ85]

Dear tigeravatar,

First of all, thank you for your answer!
I tried out your code but something is not working because the area where it should paste the TOP10 + and - rows remained empty.
Do you have any idea what would be the problem (I really just copy and paste your code into VBA)? I really appreciate your help!

NBZ85

[Osvaldo Palmeiro]

Hello. Try:

Sub ExtractBiggestSmallest()
Dim lrDa As Long, lrPa As Long, k As Long

With Sheets("Data")
  lrDa = .Range("A" & .Rows.Count).End(xlUp).Row
  .AutoFilterMode = False
  .Range("A2:C" & lrDa).AutoFilter Field:=2, Criteria1:="a"
 .Range("A2:C" & lrDa).SpecialCells(xlCellTypeVisible).Copy Sheets("Paste").Range("G1")
End With

With Sheets("Paste")
  .Range("A18:C27").Value = .Range("G1:I10").Value
  lrPa = .Cells(Rows.Count, 7).End(xlUp).Row
  .Range("A3:C12").Value = .Range("G" & lrPa - 9 & ":I" & lrPa).Value
.Columns("G:I").ClearContents
End With

End Sub

[tigeravatar]

NBZ85,

The code I provided works with your posted example file. Can you provide a sample workbook that the code doesn't work for?