3.kriteri arayarak dördüncü alanın en küçük ve en büyük değerini bulma

[energy34]

ben 3 kritere göre sorgu yapıp şayet aynılar varsa bana en küçüğünü versin istiyorum
evrengizlen hocam benzer bişey yapmış ama o kodda toplamı veriyor ben en küçük olanı çekemedim

aşağıda kodu gönderdim

Private Sub CommandButton1_Click()

Dim z, sat As Long, a(), n As Long, myarr(), deg As String, i As Long
Set z = CreateObject("Scripting.Dictionary")
sat = Cells(65536, "B").End(xlUp).Row
ReDim myarr(1 To 9, 1 To sat)
a = Range("B16:I" & sat).Value
For i = 1 To UBound(a, 1)
deg = a(i, 1) & a(i, 2) & a(i, 6)
If Not z.exists(deg) Then
n = n + 1
z.Add deg, n
myarr(1, n) = n
End If
myarr(2, z.Item(deg)) = a(i, 1)
myarr(3, z.Item(deg)) = a(i, 2)
myarr(4, z.Item(deg)) = a(i, 3)
myarr(5, z.Item(deg)) = z.Min burası ne olacak
myarr(6, z.Item(deg)) = a(i, 5)
myarr(7, z.Item(deg)) = a(i, 6)
myarr(8, z.Item(deg)) = a(i, 7)
myarr(9, z.Item(deg)) = a(i, 8)
Next
Application.ScreenUpdating = False
Range("A16:I65536").ClearContents
Range("A16").Resize(n, 9) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "Teke indirme yapıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKCancel + vbInformation, "E V R E N"


End Sub

Bu kod 3 kriteri sağlayan birden fazla satır varsa bunların 4.bir değerlerini topluyor

Aşağıdaki kodda belirtilen aralıktaki değerlerin hepsini veriyor

Private Sub CommandButton1_Click()




Dim s1 As Worksheet, sh As Worksheet, sat As Long, i As Long
Dim z As Object, isim As String
Set s1 = Sheets("DataBase")
sat = s1.Cells(65536, "B").End(xlUp).Row


s1.Range("A1").AutoFilter
Set z = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
On Error Resume Next


s1.Range("K1") = 1
s1.Range("K1").Copy
s1.Range("F2:F" & sat).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
s1.Range("F2:F" & sat).NumberFormat = "[$-F400]h:mm:ss AM/PM"
s1.Range("A1").Select
For i = 2 To sat
isim = "oglen"
isim = UCase(Replace(Replace(isim, "y", "I"), "i", "Y"))
If Not z.exists(isim) Then
z.Add (isim), Nothing
For Each sh In Worksheets
If UCase(Replace(Replace(sh.Name, "y", "I"), "i", "Y")) = isim Then
sh.Range("A1:F65536").ClearContents

s1.Range("A1").AutoFilter Field:=2, Criteria1:="T.GIRIS", Operator:=xlOr, Criteria2:="T.CIKIS", Operator:=xlOr
s1.Range("A1").AutoFilter Field:=6, Criteria1:=">09:05:00", Operator:=xlOr, Criteria2:="<18:00:00"



s1.Range("A1:F" & sat).CurrentRegion.Copy sh.Range("A1")
s1.Range("A1").AutoFilter
Exit For
End If
Next
End If
Next i


Application.ScreenUpdating = True
MsgBox "Sayfalara aktarma basari ile yapildi." & _
vbLf & "BIEM basarilar diler...", vbOKOnly + vbInformation, "IAB"




End Sub


ekli dosyada da isteğimi belirttim

şimdiden teşekkür ederim

 

[Orion1]

E sütunundaki en küçük değeri alır.

Sub benzersiz_min()
Dim z, sat As Long, a(), n As Long, myarr(), deg As String, i As Long
Set z = CreateObject("Scripting.Dictionary")
sat = Cells(65536, "B").End(xlUp).Row
ReDim myarr(1 To 9, 1 To sat)
a = Range("B16:I" & sat).Value
For i = 1 To UBound(a, 1)
deg = a(i, 1) & a(i, 2) & a(i, 6)
If Not z.exists(deg) Then
n = n + 1
z.Add deg, n
myarr(1, n) = n
End If
myarr(2, z.Item(deg)) = a(i, 1)
myarr(3, z.Item(deg)) = a(i, 2)
myarr(4, z.Item(deg)) = a(i, 3)
If myarr(5, z.Item(deg)) = "" Then
    myarr(5, z.Item(deg)) = a(i, 4)
    ElseIf a(i, 4) < myarr(5, z.Item(deg)) Then
    myarr(5, z.Item(deg)) = a(i, 4)
End If
myarr(6, z.Item(deg)) = a(i, 5)
myarr(7, z.Item(deg)) = a(i, 6)
myarr(8, z.Item(deg)) = a(i, 7)
myarr(9, z.Item(deg)) = a(i, 8)
Next
Application.ScreenUpdating = False
Range("A16:I65536").ClearContents
Range("A16").Resize(n, 9) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "Teke indirme yapıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKCancel + vbInformation, "E V R E N"


End Sub

 

[energy34]

evren hocam çok çok çok saol

 

[Orion1]

evren hocam çok çok çok saol

Rica ederim.
İyi çalışmalar.