Help VBA code Filter then find Max, Min, Average value

sbv1986

Board Regular
Joined
Nov 2, 2017
Messages
87
Hi all:

I want to filter Column(A) from sheets(main).range(H1:lastrow), then Filter column(B) = "R-1234"

After Filter then find row Max, Min, Average in Sheet(A1234).range(Q2:Q9999)
Fill "MAX", "MIN" in column(R), Fill average.Value in column(S)

My code belove but can run't that I want. It's alway find Max, Min value of all data, not in filter data.
Please help me...

VBA Code:
Public Sub Get_DATA()
Dim cn As Object, rs As Object, i As Byte, lr As Long, lR2 As Long, z As Long, fso As Object
Dim lrow As Long, lRowI As Long, ans As Long, ii As Long, x As Long, y As Long, iRng As Range, iMin As Double, iMax As Double

With ThisWorkbook.Sheets("main")
    lrow = .Cells(Rows.Count, "H").End(xlUp).Row
    For i = 1 To lrow
        ans = Sheets("main").Range("H" & i).Value
        lRowI = Sheets("A1234").Cells(Rows.Count, "A").End(xlUp).Row
        With Sheets("A1234")
            .Range("A1:A" & lRowI).AutoFilter Field:=1, Criteria1:="*" & ans & "*", Operator:=xlOr, Criteria2:=ans
            .Range("A1:A" & lRowI).AutoFilter Field:=2, Criteria1:="R-1234"
            Set iRng = .Range("Q2:Q9999").SpecialCells(xlCellTypeVisible)
                iMax = Application.WorksheetFunction.Max(iRng)
                iMin = Application.WorksheetFunction.Min(iRng)
                .Range("U" & .Range("C" & Rows.Count).End(xlUp).Row).Value = WorksheetFunction.Average(.Range("Q2:Q9999").SpecialCells(xlCellTypeVisible))
                    x = .Range("Q2:Q9999").Find(iMax).Row
                    y = .Range("Q2:Q9999").Find(iMin).Row
                    .Range("R" & x).Value = "MAX"
                    .Range("R" & y).Value = "MIN"
                    .Range("S" & x).Value = Application.WorksheetFunction.CountIfs(.Range("A2:A9999"), ans, .Range("Q2:Q9999"), "<" & .Range("Q1"))
            .Range("A1:A" & lRowI).AutoFilter
        End With
    Next i
    Application.CutCopyMode = False
End With

End sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
It's difficult to work out what your code is doing without the sheet or examples of data.

Untested guess, outputs values into T1 as a table, not adding MAX and MIN to specific rows:
Code:
Public Sub Get_Data_v1()

    Dim LR  As Long
    Dim x   As Long
    Dim a   As Variant
  
    With Sheets("Main")
        LR = .Cells(.Rows.Count, 8).End(xlUp).Row - 1
        a = .Cells(1, 8).Resize(LR, 4).Value
        a(1, 1) = "Value": a(1, 2) = "Max": a(1, 3) = "Min": a(1, 4) = "Average"
    End With 
 
    With Sheets("A1234")
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For x = LBound(a, 1) To UBound(a, 1)
            a(x, 2) = Evaluate("=MAX(IF((A2:A" & LR & "=""*"" &" & a(x, 1) & "&""*"")+(A2:A" & LR & "=" & a(x, 1) & ")*(B2:B" & LR & "=""R-1234""),Q2:Q" & LR & "))")
            a(x, 3) = Evaluate("=MIN(IF((A2:A" & LR & "=""*"" &" & a(x, 1) & "&""*"")+(A2:A" & LR & "=" & a(x, 1) & ")*(B2:B" & LR & "=""R-1234""),Q2:Q" & LR & "))")
            a(x, 4) = Evaluate("=AVERAGE(IF((A2:A" & LR & "=""*"" &" & a(x, 1) & "&""*"")+(A2:A" & LR & "=" & a(x, 1) & ")*(B2:B" & LR & "=""R-1234""),Q2:Q" & LR & "))")
        Next x
        .Cells(1, 20).Resize(UBound(a, 1), UBound(a, 2)).Value = a
    End With 
 
    Erase a
 
End Sub
 
Upvote 0
You can use AGGREGATE function to ignore the hidden row.
Example:
VBA Code:
Sub try362()
Dim c As Range
    ActiveSheet.AutoFilterMode = False
    With Range("A1:A10")
        .AutoFilter Field:=1, Criteria1:="D"
        On Error Resume Next
        Set c = .Offset(, 1).SpecialCells(xlCellTypeVisible) 'get col B
        Range("D1") = WorksheetFunction.Aggregate(4, 5, c) 'max
        Range("E1") = WorksheetFunction.Aggregate(5, 5, c) 'min
        Range("F1") = WorksheetFunction.Aggregate(1, 5, c) 'average
        On Error GoTo 0
    End With

End Sub

Book1
AB
1nameno
2D1
3V2
4M3
5D4
6V5
7M6
8D7
9V8
10M9
Sheet5


RESULT:
Book1
ABCDEF
1nameno714
2D1
5D4
8D7
Sheet5
 
Upvote 0

Forum statistics

Threads
1,213,539
Messages
6,114,221
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top