excel dosya açılır açılmaz kapanıyor

[kardelen79]

arkadaşlar kolay gelsin bu makroda nerede hata var bakabilirmisin satır sayısı çok olunca sistem otamatik kapatıyor 4,5 satır varken sistem çalışıyordu bu satırların sayısı 300 kadar varacak ozaman hiç açılmayacak sanırım bir yardımcı olursanız sevinirim şimdiden çok sağolun

 

[Saban Sertkaya]

Merhabalar, alternatif link paylaşabilir misiniz ?

 

[Tevfik_Kursun]

Merhaba Arkadaş,
Ben de kapanmadı. Sanırım sizde ekran dışına çıkmış. (sanki ikinci bir ekran var gibi!)
İyi çalışmalar

 

[kardelen79]

abi dış veri geliyor sizde o veri olmadığı için problem olmaz

 

[kardelen79]

burda yapmak istediğim A8:A96 Hücrelerine anlık veri geliyor bu A 96 Kadar ama bunu biraz çogaltabilirim B8:B96 HÜCRESİNDEN A8:A96 hücresini çıkarıyorum C8:C96 hücresine sonucu yazdırıyorum Burada C sütununda çıkan sonuç A 2 hücresine eşit veya küçük ise ve T sütundaki rakam sıfıra eşit ise A 8 HÜCRESİNİ B8 hücresine kopyalayıp yapıştırmasını istiyorum ..
Yine aynı büyük olursa Burada C sütununda çıkan sonuç B 2 hücresine eşit veya büyük ise ve T sütundaki rakam sıfıra eşit ise A 8 HÜCRESİNİ B8 hücresine kopyalayıp yapıştırmasını istiyorum .

 

[Ömer]

Merhaba,

Deneyiniz. Eski kodların çalışma mantığının doğru olduğu varsayılarak küçük düzenlemeler yapıldı.

Private Sub Worksheet_Calculate()

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With

    adegeri = Sayfa1.Range("a2").Value
    bdegeri = Sayfa1.Range("b2").Value
    
    
    For i = 8 To Cells(Rows.Count, "A").End(xlUp).Row
        cdegeri = Sayfa1.Range("c" & i).Value
        egeri = Sayfa1.Range("t" & i).Value
    
        If cdegeri < adegeri Or cdegeri > bdegeri Then
            If tdegeri = "0" Then
                Sayfa1.Range("b" & i) = Sayfa1.Range("a" & i)
            End If
        End If
        
    Next i
    
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[kardelen79]

ÖMER ABİ OLMADI

 

[Ömer]

Olmayan nedir?

 

[kardelen79]

abi sıfırlama yapmıyor C hücresindeki değerler A2 VE B2 değerlerini aşmasına rağmen değişmiyor

 

[Ömer]

Ben kodlarda değiştirme yapmadım, sadece hızlanması için bazı dokunuşlar yaptım.

 

[kardelen79]

burda yapmak istediğim A8:A96 Hücrelerine anlık veri geliyor bu A 96 Kadar ama bunu biraz çogaltabilirim B8:B96 HÜCRESİNDEN A8:A96 hücresini çıkarıyorum C8:C96 hücresine sonucu yazdırıyorum Burada C sütununda çıkan sonuç A 2 hücresine eşit veya küçük ise ve T sütundaki rakam sıfıra eşit ise A 8 HÜCRESİNİ B8 hücresine kopyalayıp yapıştırmasını istiyorum ..
Yine aynı büyük olursa Burada C sütununda çıkan sonuç B 2 hücresine eşit veya büyük ise ve T sütundaki rakam sıfıra eşit ise A 8 HÜCRESİNİ B8 hücresine kopyalayıp yapıştırmasını istiyorum

 

[Ömer]

Eski kodlarda doğru sonuç veriyor muydu. İncelerseniz kodlarda değişiklik yapmadığımı görebilirsiniz.

Birde bu şekilde deneyin.

Private Sub Worksheet_Calculate()
 
   Dim alan, s As Long, son As Long, i As Long, a As Double, b As Double

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
 
    son = Cells(Rows.Count, "A").End(xlUp).Row
    alan = Range("A8:T" & son).Value
    a = Range("A2").Value
    b = Range("B2").Value
 
    ReDim dizi(1 To son, 1 To 20)
 
    For i = LBound(alan) To UBound(alan)
        s = s + 1
        dizi(s, 1) = alan(i, 2)
        If (alan(i, 3) < a Or alan(i, 3) > b) And alan(i, 20) = 0 Then
            dizi(s, 1) = alan(i, 1)
        End If
    Next i
 
    Range("B8").Resize(s, 1) = dizi
 
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[kardelen79]

abi bunu başka bir kitaba aktarınca çalışmaz mı

 

[kardelen79]

ömer abi sistem çalıştı ama kendi asıl sayfama yükleyince sistem çalışmadı

 

[Ömer]

Asıl sayfanızdaki sistem farklı mı? Örnek dosyanızla aynı değil mi?

 

[kardelen79]

aynı sayılır abi

 

[kardelen79]

bu nu uygulayacagım abi

 

[Ömer]

Eski kodlar bu dosyada çalışıyor muydu?

Birde bu şekilde deneyiniz.

Private Sub Worksheet_Calculate()
 
   Dim alan, s As Long, son As Long, i As Long, a As Double, b As Double

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With
 
    son = Cells(Rows.Count, "A").End(xlUp).Row
    alan = Range("A8:T" & son).Value
    a = Range("A2").Value
    b = Range("B2").Value
 
    ReDim dizi(1 To son, 1 To 20)
 
    For i = LBound(alan) To UBound(alan)
        s = s + 1
        dizi(s, 1) = alan(i, 2)
        If Not IsError(alan(i, 3)) And Not IsError(alan(i, 20)) Then
            If (alan(i, 3) < a Or alan(i, 3) > b) And alan(i, 20) = 0 Then
                dizi(s, 1) = alan(i, 1)
            End If
        End If
    Next i
 
    Range("B8").Resize(s, 1) = dizi
 
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[kardelen79]

abi sağolasın oldu sanırım