tarih doldurma formülü makro ile tanımlama

[adamar]

Merhaba excel üstadlarımız.
ekli dosya da tarih doldurulması ile ilgili bir çalışmam var.
bu şekli çalışıyor olmasına karşın formülleri çok fazla bilgisayarı kasıyor ve verilerin dolması zaman alıyor.
Tabloyu makro ile çalıştırabilme imkanımız varsa yardımcı olurmusunuz.
İlgilenenlere şimdiden çok teşekkürler

Türker

 

[uzmanamele]

merhaba

makro ile tabiiki olur ama siz neden mevcut formülünüzü daha kullanışlı hale getirmeyi denemediniz?

C3: DU22 arasındaki formül

=TOPLA.ÇARPIM(--('kayıt giris'!$C$3:$C$50000>=C$2);--('kayıt giris'!$B$3:$B$50000<=C$2);--('kayıt giris'!$A$3:$A$50000=$B3))

bu yetmezmiş gibi birde koşullu biçimlendirme var.
her veri girişinde formüller tetiklendiği için bu dosyayı kullanmanız imkansız hale gelir.

çok gerekmeyen koşullu biçimlendirmeleri kaldırmanızı öneririm.
formülde kullandığınız $C$3:$C$50000 gibi alanları dinamik alan olarak formülleyin.
kayıt girişi sayfanızın son dolu satırında bitirin, satır arttıkca alanınız büyür ve hesabınız hızlanır.

 

[Kemal Demir]

Merhaba,

Ek'teki dosyayı inceleyiniz.

Makro Butona bağlanmıstır.

 

[Necdet]

Merhaba,

Sayın Kemal Demir yanıtlamış ama bende üzerinde çalışmıştım, boşa gitmesin.

Sub BulRenklendir()
Dim i As Long
Dim BasKol As Integer, BitKol As Integer
Dim Sat As Long
Dim c As Range
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim Aranan As String
Set s1 = Sheets("Kayıt giris")
Set s2 = Sheets("Tarih Takip")
s2.Select
Application.ScreenUpdating = False
BitKol = [IV2].End(1).Column
Sat = [B65536].End(3).Row
Range(Cells(3, 3), Cells(Sat, BitKol)).Interior.ColorIndex = xlNone
For i = 3 To s1.[A65536].End(3).Row
    Set c = s2.Range("B:B").Find(s1.Cells(i, "A"), LookIn:=xlValues)
    If Not c Is Nothing Then
        Sat = c.Row
    End If
    
    If Sat > 0 Then
    
        Aranan = Format(s1.Cells(i, "B"), "d\/m")
        Set c = s2.Range("2:2").Find(Aranan, LookIn:=xlValues)
        If Not c Is Nothing Then
            BasKol = c.Column
        End If
        
        Aranan = Format(s1.Cells(i, "C"), "d\/m")
        Set c = s2.Range("2:2").Find(Aranan, LookIn:=xlValues)
        If Not c Is Nothing Then
            BitKol = c.Column
        End If
        
        For BasKol = BasKol To BitKol
            If Cells(Sat, BasKol).Interior.ColorIndex = xlNone Then
               Cells(Sat, BasKol).Interior.ColorIndex = 15
            Else
               Cells(Sat, BasKol).Interior.ColorIndex = 5
            End If
        Next BasKol
'        Range(Cells(Sat, BasKol), Cells(Sat, BitKol)).Interior.ColorIndex = 15
        
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Boyama Tamamlandı....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[Kemal Demir]

Necdet Bey,

Gayet güzel ve estetik bir çalışma olmuş.

Ben şimdi fark ettim.(Orneğinizi incelediğim zaman ) 8 Mayıs ile 15 Mayıs arası araç rezerv edildiği halde ben sadece 8 ine ve 15'ine değer yazdırdım.

Atladıgım bir konu idi.Teşekkurler.

 

[Necdet]

Rica ederim Kemal Bey,

Bende başlangıçta sadece renklendireyim dedim, fakat Süleyman Beyin açıklamasını okuduktan sonra uyandım.

Umarım arkadaşımızın işine yarar.

 

[Kemal Demir]

Hocam ,
Send ettiğimde sende okumussun..
Çok iyi ya.
Görüşmek üzere.

 

[Kemal Demir]

Hocam birde ben zannımca yanLıs cevaplamısım

 

[Necdet]

Kemal hocam canınız sağolsun, yanlışlık insanlara mahsus.

Ben doğru mu yanıtladım açıkça pek bilmiyorum, 1-2 veriye bakıp tamam deyip yolladım dosyayı.

 

[adamar]

Sayın Hocalarım Muhteşemsiniz.
Çok Teşekkür ederim.
Türker