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
