Eki inceler misiniz?

---

Kodlar
ana Fonksiyon

Function TekDeger()



SonStr = Range("A" & Rows.Count).End(3)(2, 1).Row

Set Bolge = Range("A2:A" & SonStr)



Dim tmp As String

Dim Benzersiz() As Variant



sinir = 0

tmp = ""

  For Each cell In Bolge

      If (cell <> "") And (InStr("|" & tmp & "|", "|" & cell & "|") = 0) Then

        tmp = tmp & cell & "|"

        ReDim Preserve Benzersiz(1, sinir)

      Benzersiz(0, sinir) = cell

      Benzersiz(1, sinir) = Range("B" & cell.Row)

      sinir = sinir + 1

      End If

  Next cell

  Benzersiz = Application.Transpose(Benzersiz)

Dim SonDizi() As Variant

ReDim SonDizi(UBound(Benzersiz), 3)





Indx = 0

For x = LBound(Benzersiz) To UBound(Benzersiz)



TmpMin = MinBul(Benzersiz(x, 1))



SonDizi(Indx, 0) = Benzersiz(x, 0 + 1)

SonDizi(Indx, 1) = Benzersiz(x, 1 + 1)

SonDizi(Indx, 2) = Split(TmpMin, ";")(0)

SonDizi(Indx, 3) = Split(TmpMin, ";")(1)

Indx = Indx + 1

Next x



SonStr = Range("g" & Rows.Count).End(3)(2, 1).Row

    Range("H2:K" & SonStr).ClearContents

    Range("H2").Resize(UBound(SonDizi), 4).Value = SonDizi

MsgBox "işlem bitti"

End Function

Minumum değeri bulma fornksiyonu

Function MinBul(ByVal KodDgr As String) As String



Dim Bolge As Range



Dim MinAcik As Double

Dim MinKapali As Double



MinAcik = 0

MinKapali = 0

x = 0

SonStr = Range("A" & Rows.Count).End(3)(2, 1).Row



Set Bolge = Range("A2:A" & SonStr)

For Each cell In Bolge

      

      If (cell = KodDgr) Then

        DblTrh = TrhCevir(Range("D" & cell.Row))

        

        If MinAcik = 0 Then

            MinAcik = DblTrh

        Else

            If Range("C" & cell.Row) = "AÇIK" And DblTrh < MinAcik Then MinAcik = DblTrh

        End If

        

        If MinKapali = 0 Then

            MinKapali = DblTrh

        Else

            If Range("C" & cell.Row) = "KAPALI" And DblTrh < MinKapali Then MinKapali = DblTrh

        End If

        

        x = x + 1

      End If

  Next cell

  

  MinBul = TrhDonsEski(CDate(MinAcik)) & " ; " & TrhDonsEski(CDate(MinKapali))

End Function

Tarihe dönüştürme fonksiyonu

Function TrhCevir(Trh As String) As Double



Dim TekKod() As String

Dim Trh2() As String

Dim Zmn() As String



Trh = Trim(Trh)

TekKod = Split(Trh)

Trh2 = Split(TekKod(0), "-")

Zmn = Split(TekKod(1), ".")

        If TekKod(UBound(TekKod)) = "PM" And Zmn(0) <> 12 Then Zmn(0) = Zmn(0) + 12



Select Case Trh2(1)

    Case "JAN"

        result = 1

    Case "FEB"

        result = 2

    Case "MAR"

        result = 3

    Case "APR"

        result = 4

    Case "MAY"

        result = 5

    Case "JUN"

        result = 6

    Case "JUL"

        result = 7

    Case "AUG"

        result = 8

    Case "SEP"

        result = 9

    Case "OCT"

        result = 10

    Case "NOV"

        result = 11

    Case "DEC"

        result = 12

End Select

Trh2(1) = result

ZmnDbl = CDate(Trh2(0) & "." & Trh2(1) & "." & "20" & Trh2(2)) + TimeValue(Zmn(0) & ":" & Zmn(1) & ":" & Zmn(2))



TrhCevir = CDbl(ZmnDbl)

End Function

İlk tarihe dönüştürme fonksiyonu

Function TrhDonsEski(Trh As Date) As String 

Ayhy = Choose(Month(Trh), "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC") 

TrhDonsEski = format(Trh,"dd") & "-" & Ayhy & "-" & Format(Trh, "yy") & " " & Format(Trh, "hh.mm.ss") 

End Function