En küçük Tarih ve En büyük Tarih (rakamlar arasındaki satır sayını tespit ederek)

[cengizank]

En küçük tarihi ve en büyük tarihi formül olarak uygulamak.
A sütunundaki sıra numaralarının aralarındaki satır sayısını bularak yapılması gereken bir çalışma.

Saygı değer hocalarım,

Daha iyi açıklama olsun diye bir örnek dosya ekledim.

Saygılarımla,

 

[asi_kral]

Merhaba
Bu kodu dener misiniz_?

Option Explicit
Sub mak_min()
Dim STR As Long, BUL As Long
Application.ScreenUpdating = False
For STR = 16 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(STR, "A") <> Empty Then
BUL = STR
End If
Cells(BUL, "D") = "=MIN(D" & BUL + 1 & ":D" & STR & ")"
Cells(BUL, "E") = "=MAX(E" & BUL + 1 & ":E" & STR & ")"
Next
Application.ScreenUpdating = True
End Sub

Umarım işinize yarar.

 

[cengizank]

Sayın Hocam;

Teşekkürler kod çalışıyor

Lakin ben o hücerelere =Min() ve =Mak() formüllerini atmasını istiyorum.

D hücresine =Min(D?: D?)
E hücresine =Mak(E?:E?)

olarak yazması gerekiyor

Saygılarımla,

 

[asi_kral]

Merhaba
Yani hücrede formüller mi görünsün_?
Ben direk hesabı yaptırmayı uygun görmüştüm

 

[cengizank]

Merhaba
Yani hücrede formüller mi görünsün_?
Ben direk hesabı yaptırmayı uygun görmüştüm

Evet hocam

Hesap(tarih) değiştiğinde tekrar sıkıntı olacak,

Benim anlatmamda da sıkıntı olabilir

Hücereleri tespit edildikten sonra VB Kodu ile formülleri atanacak

 

[asi_kral]

Evet hocam

Hesap(tarih) değiştiğinde tekrar sıkıntı olacak,

Benim anlatmamda da sıkıntı olabilir

Hücereleri tespit edildikten sonra VB Kodu ile formülleri atanacak

Kod güncellemesi yapıldı.

 

[cengizank]

Kod güncellemesi yapıldı.

Teşekkürler Hocam

Cumayı mütakiben deneyip bilgilendireceğim

En derin saygılarımla,

 

[asi_kral]

Teşekkürler Hocam

Cumayı mütakiben deneyip bilgilendireceğim

En derin saygılarımla,

Kolay Gelsin.

 

[cengizank]

Kolay Gelsin.

Hocam test ettim.

Tek kelime ile Harika olmuş.

 

[Ömer]

Merhaba,

Alternatif olsun.

Sub BulYaz()
 
    Dim Dizi(), i As Long, Hucre As Range, son As Long, j As Long
    Dim a As Long, b As Long
 
    On Error Resume Next
    son = Cells(Rows.Count, "D").End(xlUp).Row
 
    For Each Hucre In Range("B16:B" & son).SpecialCells(xlCellTypeBlanks)
        ReDim Preserve Dizi(0 To i)
        Dizi(i) = Hucre.Row
        i = i + 1
    Next
 
    ReDim Preserve Dizi(0 To i)
    Dizi(i) = son + 1
 
    For j = 0 To UBound(Dizi) - 1
        a = Dizi(j): b = Dizi(j + 1)
        Cells(a, "D") = "=MIN(D" & a + 1 & ":D" & b - 1 & ")"
        Cells(a, "E") = "=MAX(E" & a + 1 & ":E" & b - 1 & ")"
    Next j
 
End Sub

.

 

[cengizank]

Ömer hocam;

Sizin kodları aldım deneyeceğim.

Saygılarımla,

 

[cengizank]

Sayın Ömer ve asi kral 1967 hocam;

Kod denemlerimde şu sıkıntılara denk geldim. Buralara bağlı hücerelerde veri güncellemesi yaparken süre çok uzuyor.

Aşağıdaki kodu kullandım

Hızı bayağı değişti.

sub modüladi()
[COLOR="Red"]Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False[/COLOR] [COLOR="Blue"]'burayı sizlerden öğrenmiştim[/COLOR]

kodlar......


[COLOR="red"]Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic[/COLOR]

end sub

xlCalculationManual ' değişiklik yapılacak yerlerdeki hücrelere bağlı olarak çalışan diğer hücrelerin otomatik hesaplamasını geçici olarak durduruyorum

Sonra otomatik hesaplamayı devreye sokuyorum

Tüm arkadaşlara faydası olması dileğiyle