Dosyayı hesaplama süresi çok fazla

[safir33]

Değerli arkadaşlar;
Ekte yolladığım dosyayı her geliştirmeye çalıştığımda (örneğin, BB-BD arasında en son üç sütun formül ekledim). Benim bilgisayarımda 30 sn de hesaplama yaparken ekleme yaptığım formüller sonucunda 100 saniyeyi aştığı oldu. Bunu bir idareci arkadaşım kullanacak. Hatamı da biliyorum, kullandığım formül şekillerim çok ağırlaştırıyor. Fakat daha kolay formülleri kullanma konusunda pek yetenekli değilim. Bu dosyayı da zaten sizlerin katkıları ile bu haline getirebildim. Şu haliyle de kullanması pek mümkün görünmüyor. Dosyamı hafifletme konusunda yardımlarınızı bekliyorum. Aslında bundan 20 yıl önce düzinelerce sayfalardan ve dolu dolu formüllerden oluşan bir küçük okul programı yapmıştım ama bu kadar ağır değildi Yardım ederseniz çok sevinirim. Bir de bu daha veri girilmemiş hali. Veri girdikçe daha da ağırlaşacaktır.

 

[Ziynettin]

Öğrenci devamsızlık durumu sayfanızda [G7:BD?] aralığı veriler formul ile değil makro olarak düzenlemeye çalıştım.

 

[safir33]

Öğrenci devamsızlık durumu sayfanızda [G7:BD?] aralığı veriler formul ile değil makro olarak düzenlemeye çalıştım.

Ziynettin hocam emeklerinize sağlık çok güzel olmuş. Allah razı olsun, destekleriniz benim gibi acemi insanlara çok ışık tutuyor. Çalışmalarınızda kolaylıklar diliyorum.

 

[safir33]

Öğrenci devamsızlık durumu sayfanızda [G7:BD?] aralığı veriler formul ile değil makro olarak düzenlemeye çalıştım.

Ziynettin hocam; hafta sayfalarında okul numarası olmasına rağmen veri girişi yapılan "öğrenci devamsızlık durumu" sayfasında numarası olmayanları mesaj kutusuna dahil edebilmeniz mümkün müdür? Kullanıcı hatasını ortadan kaldırması açısından bunu da dahil edebilirseniz çok sevinirim hocam.

 

[Ziynettin]

Sub snc()
Z = TimeValue(Now)
Application.ScreenUpdating = False
Set dc = CreateObject("scripting.dictionary")

    For x = 1 To Worksheets.Count
        Set s1 = Sheets(x)
        If "HAFTA" = Right(s1.Name, 5) Then
            sat = s1.Cells(Rows.Count, 3).End(3).Row
            sut = s1.Rows(3).Find("*", , , , xlByColumns, xlPrevious).Column
            a = s1.Range(s1.[D3], s1.Cells(sat, sut)).Value
            For i = 2 To UBound(a)
                For j = 1 To UBound(a, 2)
                If a(i, j) <> "" Then p1 = p1 + 1
                    krt = CStr(a(i, j)) & "|" & a(1, j)
                    dc(krt) = dc(krt) + 1
                Next j
            Next i
        End If
    Next x
    
Set s2 = Sheets("ÖĞRENCİ DEVAMSIZLIK DURUMU")
son = s2.Cells(Rows.Count, 4).End(xlUp).Row
b = s2.Range("D6:Ac" & son).Value
ReDim c(1 To UBound(b), 1 To UBound(b, 2) - 3)

    For i = 2 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2)
            krt = CStr(b(i, 1)) & "|" & b(1, j)
            If dc.exists(krt) Then
                c(say, j - 3) = dc(krt)
            End If
        Next j
    Next i

k = s2.Range("AD5:AZ6").Value
ReDim v(1 To say, 1 To UBound(k, 2) + 2)
ReDim w(1 To say, 1 To 2)
    For i = 1 To say
        For j = 1 To UBound(k, 2)
            If k(1, j) <> "" Then
                If c(i, j) > k(1, j) * 6 Then
                    v(i, j) = "KALDI"
                    v(i, UBound(k, 2) + 2) = b(i + 1, 1)
                    
                    If v(i, UBound(k, 2) + 2) <> "" Then
                        m = m + 1
                        w(m, 1) = b(i + 1, 1)
                        w(m, 2) = b(i + 1, 2)
                    Else
                        
                    End If
                Else
                    v(i, j) = ""
                  
                End If
                
            End If
            
        Next j
    Next i

s2.Range("G7:BD" & Rows.Count).ClearContents
s2.[G7].Resize(say, UBound(b, 2) - 3) = c
s2.[AD7].Resize(say, UBound(k, 2) + 2) = v
s2.[BC7].Resize(m, 2) = w
Application.ScreenUpdating = True
MsgBox "İşlem Tamam...." & vbLf & vbLf & _
    p1 & " :  Adet devamsızlık bulundu." & vbLf & vbLf & _
    CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[safir33]

Sub snc()
Z = TimeValue(Now)
Application.ScreenUpdating = False
Set dc = CreateObject("scripting.dictionary")

    For x = 1 To Worksheets.Count
        Set s1 = Sheets(x)
        If "HAFTA" = Right(s1.Name, 5) Then
            sat = s1.Cells(Rows.Count, 3).End(3).Row
            sut = s1.Rows(3).Find("*", , , , xlByColumns, xlPrevious).Column
            a = s1.Range(s1.[D3], s1.Cells(sat, sut)).Value
            For i = 2 To UBound(a)
                For j = 1 To UBound(a, 2)
                If a(i, j) <> "" Then p1 = p1 + 1
                    krt = CStr(a(i, j)) & "|" & a(1, j)
                    dc(krt) = dc(krt) + 1
                Next j
            Next i
        End If
    Next x
   
Set s2 = Sheets("ÖĞRENCİ DEVAMSIZLIK DURUMU")
son = s2.Cells(Rows.Count, 4).End(xlUp).Row
b = s2.Range("D6:Ac" & son).Value
ReDim c(1 To UBound(b), 1 To UBound(b, 2) - 3)

    For i = 2 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2)
            krt = CStr(b(i, 1)) & "|" & b(1, j)
            If dc.exists(krt) Then
                c(say, j - 3) = dc(krt)
            End If
        Next j
    Next i

k = s2.Range("AD5:AZ6").Value
ReDim v(1 To say, 1 To UBound(k, 2) + 2)
ReDim w(1 To say, 1 To 2)
    For i = 1 To say
        For j = 1 To UBound(k, 2)
            If k(1, j) <> "" Then
                If c(i, j) > k(1, j) * 6 Then
                    v(i, j) = "KALDI"
                    v(i, UBound(k, 2) + 2) = b(i + 1, 1)
                   
                    If v(i, UBound(k, 2) + 2) <> "" Then
                        m = m + 1
                        w(m, 1) = b(i + 1, 1)
                        w(m, 2) = b(i + 1, 2)
                    Else
                       
                    End If
                Else
                    v(i, j) = ""
                 
                End If
               
            End If
           
        Next j
    Next i

s2.Range("G7:BD" & Rows.Count).ClearContents
s2.[G7].Resize(say, UBound(b, 2) - 3) = c
s2.[AD7].Resize(say, UBound(k, 2) + 2) = v
s2.[BC7].Resize(m, 2) = w
Application.ScreenUpdating = True
MsgBox "İşlem Tamam...." & vbLf & vbLf & _
    p1 & " :  Adet devamsızlık bulundu." & vbLf & vbLf & _
    CDate(TimeValue(Now) - Z), vbInformation
End Sub

Sayın hocam ben anlatamadım büyük ihtimalle; örneğin 9999 diye bir numara girdim 1.hafta bölümüne, fakat bu numara "öğrenci devamsızlık durumu" sayfasında görmediği yada eşleşmediği anda sizin yaptığınız msj box kutusunda 9999 numaralı öğrenci kayıtlı değil diyecek örneğin. bunu yapmamızın sebebi de sürekli yeni kayıtlar geliyor, amaç kullanıcıyı uyarması. Zahmet olmazsa hocam.

 

[Ziynettin]

Sub snc()
Z = TimeValue(Now)
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
    For x = 1 To Worksheets.Count
        Set s1 = Sheets(x)
        If "HAFTA" = Right(s1.Name, 5) Then
            sat = s1.Cells(Rows.Count, 3).End(3).Row
            sut = s1.Rows(3).Find("*", , , , xlByColumns, xlPrevious).Column
            a = s1.Range(s1.[D3], s1.Cells(sat, sut)).Value
            For i = 2 To UBound(a)
                For j = 1 To UBound(a, 2)
                If a(i, j) <> "" Then
                    krt = CStr(a(i, j)) & "|" & a(1, j)
                    dc(krt) = dc(krt) + 1
                    ds(a(i, j)) = ""
                End If
                Next j
            Next i
        End If
    Next x
Set s2 = Sheets("ÖĞRENCİ DEVAMSIZLIK DURUMU")
son = s2.Cells(Rows.Count, 4).End(xlUp).Row
b = s2.Range("D6:Ac" & son).Value
ReDim c(1 To UBound(b), 1 To UBound(b, 2) - 3)

    For i = 2 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2)
            krt = CStr(b(i, 1)) & "|" & b(1, j)
            If dc.exists(krt) Then
                c(say, j - 3) = dc(krt)
            End If
        Next j
        
        deg = b(i, 1)
        If Not ds.exists(deg) Then
            w1 = w1 + 1
        Else
            w2 = w2 + 1
        End If
    Next i
    
k = s2.Range("AD5:AZ6").Value
ReDim v(1 To say, 1 To UBound(k, 2) + 2)
ReDim w(1 To say, 1 To 2)
    For i = 1 To say
        For j = 1 To UBound(k, 2)
            If k(1, j) <> "" Then
                If c(i, j) > k(1, j) * 6 Then
                    v(i, j) = "KALDI"
                    v(i, UBound(k, 2) + 2) = b(i + 1, 1)
                    If v(i, UBound(k, 2) + 2) <> "" Then
                        m = m + 1
                        w(m, 1) = b(i + 1, 1)
                        w(m, 2) = b(i + 1, 2)
                    End If
                Else
                    v(i, j) = ""
                End If
            End If
        Next j
    Next i

s2.Range("G7:BD" & Rows.Count).ClearContents
s2.[G7].Resize(say, UBound(b, 2) - 3) = c
s2.[AD7].Resize(say, UBound(k, 2) + 2) = v
s2.[BC7].Resize(m, 2) = w

ack1 = "Hafta Sayfalarında bulunduğu halde bu Sayfa D sütununda bulunmayan :  " & w1
ack2 = "Hafta Sayfalarında olup ve bu Sayfa D sütununda da bulunan :  " & w2
MsgBox "İşlem Tamam...." & vbLf & vbLf & ack1 & vbLf & vbLf & ack2 & vbLf & vbLf & _
    "İşlem süreniz ;  " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[safir33]

Hocam istenilen sonucu vermiyor ama o kadar uğraştınız çok teşekkür ederim yardımlarınız için. İşlerinizde kolaylıklar diliyorum hocam.