VBA - program query on query

[cue147pro]

hi,

I want to build a VBA query that selects the results I want and write the results in a different sheet. Below I added the data and the expected results(I don't know how to do it elseway). Basically what I want to set is the following:

The data is in column A to E. For the query
column D <0.5
column E<2

column B = top 5 performers given D<0.5 and E<2

column C = top 3 given D<0.5, E<2, B=top 5

The result of the query should be the letter in column A and has to be saved in the next sheet.

Column A Column B Column C Column D Column E
AA 5 8 0.56 1.65
BB -6 12 1.5 1.90
CC 8 14 0.2 1.10
DD 9 -40 0.7 1.00
EE 47 56 0.9 1.90
FF 98 89 0.3 2.83
GG 216 47 2 2.91
HH 56 -24 2.5 2.79
II 479 -5 0.99 2.46
JJ 1 7 0.1 1.97
KK 20 45 0.25 1.64
LL 23 7 0.67 1.56
MM 56 32 2.1 1.51
NN 78 91 0.4 1.81
OO 98 -56 0.9 1.31
PP -6 -71 1.8 1.96
QQ -89 61 2.1 1.24
RR 12 -3 0.97 1.87
SS 79 86 0.53 1.43
TT 35 14 0.48 1.57
UU 49 19 1.6 1.92
VV 76 21 0.2 1.41
WW 89 25 0.56 2.53
XX 9 -8 0.78 2.41
YY -45 46 0.98 1.42
ZZ -15 73 1.43 1.81

Results of query:
NN, SS, EE

these 3 should then be saved in sheet 2 as a result.

I know the first 2 conditions are simple if ... then ... statements, but then I get in trouble with the top 5 and top 3 of the top 5 and saving the result ...

thanks in advance for ur input ...



[/img]

 

[Andrew Poulsom]

Try:

Sub Test()
    Const DVal As Double = 0.5
    Const EVal As Double = 2
    Dim Sh1 As Worksheet
    Dim Rng As Range
    Dim Sh2 As Worksheet
    Dim ShTemp As Worksheet
    Dim r As Long
    Dim Cell As Range
    Application.ScreenUpdating = False
    Set Sh1 = Worksheets("Sheet1")
    With Sh1
        Set Rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    Set Sh2 = Worksheets("Sheet2")
    Set ShTemp = Worksheets.Add
    ShTemp.Range("A1:E1").Value = Array("Col1", "Col2", "Col3", "Col4", "Col5")
    r = 2
    For Each Cell In Rng
        If Cell.Offset(0, 3).Value < DVal Then
            If Cell.Offset(0, 4).Value < EVal Then
                Cell.Resize(1, 5).Copy ShTemp.Cells(r, 1)
                r = r + 1
            End If
        End If
    Next Cell
    Set Rng = ShTemp.UsedRange
    Rng.AutoFilter Field:=2, Criteria1:="3", Operator:=xlTop10Items
    Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 1)
    Sh2.Cells.Delete
    Rng.SpecialCells(xlCellTypeVisible).Copy Sh2.Range("A1")
    Application.DisplayAlerts = False
    ShTemp.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Based on your sample data, it gives NN, TT and VV.

 

[cue147pro]

hi Andrew,

First of all, thank u very much for ur efford and input. The results I gave where indeed not entirely correct. In my new calculations I should get NN, KK, VV.

FYI: I changed in ur code "Field:=2 into Field:=3" and then I get the results I want.

Thank u for ur time

JL