RE: Formülle En Küçük Tarihleri Çekme - alicimri - 07/11/2020
Alternatif Çözüm
Kod:
Sub cevir()
son = Range("A" & Rows.Count).End(3).Row
For i = 3 To son
zaman = Range("B" & i).Value
If Right(zaman, 7) = "MERKEZİ" Then
Range("h" & i).Value = zaman
Else
Range("h" & i).Value = Application.Substitute(Application.Substitute(Application.Substitute(zaman, ".", ":"), ":", ".", 3), "000000", "")
Range("h" & i).NumberFormat = "dd.mm.yyyy hh:mm:ss.000"
End If
Next
End Sub
RE: Formülle En Küçük Tarihleri Çekme - berduş - 07/11/2020
biraz zor oldu benim için ama galiba oldu dilerim işinize yarar
maalesef istediğiniz gibi sayfaya yazılacak bir kod ile olmadı
eklenen butona basınca işlem gerçekleşir
Not: tarih alma formatınızdaki en büyük sorun gerçek tarih değeri içermemesi
mesela yıllar 2 haneli ozaman girilen tarih 2020 mi yosa 1920 mi anlaşılmıyor
ben 2000li yıllar varsayıp öyle hesaplattım ama dikkatli olunmalı
eğer gerçek verilerinizde 2000 öncesi veri varsa sorun çıkar
aşağıdaki kodlar yeni bir modül eklenip ona yapıştırılacak
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("A3:A" & SonStr)
For Each cell In Bolge
If (cell = KodDgr) And (InStr(Range("B" & cell.Row), "MERKEZİ") = 0) Then 'And (InStr(tmp, cell) = 0) Then
DblTrh = TrhCevir(Range("B" & cell.Row))
If MinAcik = 0 Then
MinAcik = DblTrh
Else
If Range("C" & cell.Row) <> "" And DblTrh < MinAcik Then MinAcik = DblTrh
End If
If MinKapali = 0 Then
MinKapali = DblTrh
Else
If Range("D" & cell.Row) <> "" And DblTrh < MinKapali Then MinKapali = DblTrh
End If
x = x + 1
End If
Next cell
MinBul = TrhDonsEski(CDate(MinAcik)) & " ; " & TrhDonsEski(CDate(MinKapali))
End Function
Function TekDeger()
SonStr = Range("A" & Rows.Count).End(3)(2, 1).Row
Set Bolge = Range("A3:A" & SonStr)
Dim tmp As String
Dim Benzersiz() As Variant
sinir = 0
For Each cell In Bolge
If (cell <> "") And (InStr("|" & tmp & "|", "|" & cell & "|") = 0) And (InStr(Range("B" & cell.Row), "MERKEZİ") > 0) Then
tmp = tmp & cell & "|"
sinir = sinir + 1
End If
Next cell
ReDim Benzersiz(sinir - 1, 1)
sinir = 0
tmp = ""
For Each cell In Bolge
If (cell <> "") And (InStr("|" & tmp & "|", "|" & cell & "|") = 0) And (InStr(Range("B" & cell.Row), "MERKEZİ") > 0) Then
tmp = tmp & cell & "|"
Benzersiz(sinir, 0) = cell
Benzersiz(sinir, 1) = Range("B" & cell.Row)
sinir = sinir + 1
End If
Next cell
Dim SonDizi() As Variant
ReDim SonDizi(UBound(Benzersiz), 3)
Indx = 0
For x = LBound(Benzersiz) To UBound(Benzersiz)
TmpMin = MinBul(Benzersiz(x, 0))
SonDizi(Indx, 0) = Benzersiz(x, 0)
SonDizi(Indx, 1) = Benzersiz(x, 1)
SonDizi(Indx, 2) = Split(TmpMin, ";")(0)
SonDizi(Indx, 3) = Split(TmpMin, ";")(1)
Indx = Indx + 1
Next x
Range("g3:j" & SonStr).ClearContents
Range("g3").Resize(UBound(SonDizi), 4).Value = SonDizi
End Function
Function TrhDonsEski(Trh As Date) As String
Ayhy = Choose(Month(Trh), "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
TrhDonsEski = Day(Trh) & "-" & Ayhy & "-" & Format(Trh, "yy") & " " & Format(Trh, "hh.mm.nn AM/PM")
End Function
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
sayfaya eklenecek bir buton ile TekDeger fonksiyonu çağrılacak
RE: Formülle En Küçük Tarihleri Çekme - feraz - 07/11/2020
Konu başlığı formülle en küçük tarihleri çekme.Biz kodla uğraşıyoruz,dahası daha ben tam kavrayamadım olayı.
Bizim yaprığımız ise tarih ve saati çıkarmak satırdaki
RE: Formülle En Küçük Tarihleri Çekme - berduş - 07/11/2020
Her kod icin acik ve kapali icin en kucuk degeri sutunlar yazdirmak accessteki gruplama ozelligi gibi
RE: Formülle En Küçük Tarihleri Çekme - alicimri - 07/11/2020
Alternatif Örnek
Kod:
Sub cevir()
son = Range("A" & Rows.Count).End(3).Row
For i = 3 To son
zaman = Range("B" & i).Value
If Right(zaman, 7) = "MERKEZİ" Then
Range("B" & i).Value = zaman
Else
Range("B" & i).Value = Application.Substitute(Application.Substitute(Application.Substitute(zaman, ".", ":"), ":", ".", 3), "000000", "")
Range("B" & i).NumberFormat = "dd.mm.yyyy hh:mm:ss.000"
End If
Next
End Sub
Sub yaz()
Run "cevir"
son = Range("A" & Rows.Count).End(3).Row
For i = 3 To son
If Range("A" & i) <> Range("A" & i - 1) Then
ilk = Range("B" & i).Row
End If
If Range("A" & i) <> Range("A" & i + 1) Then
sonu = Range("B" & i).Row
yson = Range("G" & Rows.Count).End(3).Row + 1
ActiveSheet.Range("B" & ilk & ":D" & sonu).AutoFilter Field:=2, Criteria1:="1"
Range("I" & yson).Value = CDate(Application.Subtotal(105, Range("B" & ilk & ":B" & sonu)))
Selection.AutoFilter
ActiveSheet.Range("B" & ilk & ":D" & sonu).AutoFilter Field:=3, Criteria1:="1"
Range("J" & yson).Value = CDate(Application.Subtotal(105, Range("B" & ilk & ":B" & sonu)))
Selection.AutoFilter
Range("G" & yson).Value = Range("A" & ilk).Value
Range("H" & yson).Value = Range("B" & ilk).Value
End If
Next
End Sub
Re: Formülle En Küçük Tarihleri Çekme - feraz - 07/11/2020
El birliği ile bitireceğiz inşAllah
Sub xx()
Dim dic As Object, dic1 As Object, dic2 As Object
Dim i As Long, sonNokta As Byte, parcaal
Dim degerA As String, degerB As String
Dim say As Long
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sayfa1")
.Range("G2:J" & Rows.Count).ClearContents
son = .Cells(Rows.Count, 1).End(3).Row + 1
For i = 3 To 30
degerA = CStr(.Cells(i, 1).Value)
degerB = CStr(.Cells(i, 2).Value)
Do While .Cells(i, 1).Value = .Cells(i + 1, 1).Value
If Not dic1.Exists(degerA) Then
sonNokta = InStrRev(CStr(.Cells(i + 1, 2).Value), ".") - 1
If sonNokta > 0 Then
parcaal = Format(Replace(Mid(.Cells(i + 1, 2).Value, 1, sonNokta), ".", ":"), "dd.mm.yyyy hh:mm:ss")
End If
dic2(parcaal) = parcaal
End If
i = i + 1
Loop
If dic2.Count > 0 Then
say = say + 1
.Cells(say + 2, "G").Value = degerA + 0
.Cells(say + 2, "H").Value = degerB
.Cells(say + 2, "i").Value = bubble_sort(dic2.Keys())
.Cells(say + 2, "j").Value = .Cells(say + 2, "i").Value
.Range("i:j").NumberFormat = "dd.mm.yyyy hh:mm.ss"
Set dic2 = CreateObject("Scripting.Dictionary")
End If
Next
End With
MsgBox "Bitti"
Set dic = Nothing: Set dic1 = Nothing: Set dic2 = Nothing
End Sub
Function bubble_sort(dict2)
Dim q As Long, w As Long
For q = 0 To UBound(dict2, 1) - 1
For w = q To UBound(dict2, 1)
If dict2(q) > dict2(w) Then
temp = dict2(q)
dict2(q) = dict2(w)
dict2(w) = temp
End If
Next
Next
bubble_sort = dict2(0)
End Function
|