Dinamik Hücre Değeri

[Macaroglu]

Merhabalar;

Basit bir stok programı oluşturmak istiyorum.
Mevcut Stok Değerimin yazılı olduğu hücrenin (A1), Yeni Ürün hücresine değer girdiğimde (B1), A1=A1+B1 şeklinde artmasını ve B1 hücresinin tekrar Sıfır olmasını istiyorum. Bunu nasıl yapabilirim acaba?

 

[Ömer]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [B1]) Is Nothing Then Exit Sub
    
    With Target
        If IsNumeric(.Value) = False Then Exit Sub
        [A1] = [A1] + .Value
        .Value = 0
    End With
    
End Sub

.

 

[Macaroglu]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [B1]) Is Nothing Then Exit Sub
    
    With Target
        If IsNumeric(.Value) = False Then Exit Sub
        [A1] = [A1] + .Value
        .Value = 0
    End With
    
End Sub

.

Ömer Bey teşekkür ederim ancak, kodu yapıştırdığımda Run-Time error '28' Out of Stack Space hatası verip kapanıyor excel,
Bir de A2, A3, A4 ve B2, B3, B4 hücreleri için de yapmak istesem kodu nasıl güncellemem gerekir

 

[Korhan Ayhan]

Örnek dosyayı inceleyiniz.

Harici link (Silinebilir) ; http://s6.dosya.tc/server11/phj3kb/ORNEK.rar.html

Uygulanan kod;

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B1:B4")) Is Nothing Then Exit Sub
    With Target
        If IsNumeric(.Value) Then
            Cells(.Row, "A") = Cells(.Row, "A") + .Value
            .Value = 0
        End If
    End With
End Sub

 

[Macaroglu]

İlginiz için teşekkür ederim, ama hala aynı hatayı alıyorum. Run-Time28.
Acaba değer girişi yaptıktan sonra o hücre değerini sıfır'a dönüştürdüğümüz için sonsuz döngüye mi giriyor?. Sıfır yapmak yerine hücre içini değersiz de bırakabiliriz eğer sorun çözülecekse.

 

[Macaroglu]

Debug yaptığımda şu satırı işaret ediyor;
If Intersect(Target, Range("B1:B4")) Is Nothing Then

 

[Korhan Ayhan]

Örnek dosyada denediniz mi?

 

[Macaroglu]

Evet kopyalamadan direk örnek dosyada da aynı hatayı verdi

 

[Korhan Ayhan]

Defalarca denedim. Ben problem yaşamadım.

Siz birde aşağıdaki şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, Range("B1:B4")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    With Target
        If IsNumeric(.Value) Then
            Cells(.Row, "A") = Cells(.Row, "A") + .Value
            .Value = 0
        End If
    End With
Son: Application.EnableEvents = True
End Sub

 

[Macaroglu]

Evet şuan bir problem olmadan çalışmakta. Teşekkür ederim.