Hücre Değeri Değişince Makro Çalışması ve Sonsuz Döngü Sorunu

ToHaNS · Cumartesi saat 18:39'de

Kıymetli hocalarım merhaba,

Başlıkta da belirttiğim gibi, bir tabloda hücrenin içeriği değiştiğinde verilerde dönüşüm ve güncelleme yapmaya çalışıyorum. Yazılı olan kodları forumdaki benzer eski konuları inceleyerek kendime göre uyarlamaya çalıştım fakat, sanıyorum bir çok hücrede işlem yapmak istediğim için sonsuz döngüye giriyor ve excel kapatılıyor.

Tablomun B1 sütununda USD/CAD paritesi D1 sütununda ise CAD/USD paritesi bulunmakta.

B kolonuna bir rakamsal değer girdiğimde C kolonunda CAD karşılığını,
C kolonuna bir rakamsal değer girdiğimde B kolonunda USD karşılığını yazdırmaya çalıştım.

Bu para birimlerinin dönüşüm işlemini; B ile C sütunları kendi arasında, E ile F sütunları kendi arasında, G ile H, I ile J, K ile L, M ile N, O ile P sütunları kendi aralarında şeklinde ilerliyor. (Örnek dosyada sanırım daha iyi anlaşılacaktır diye ümit ediyorum)

Ayrıca bu dönüşümlerin sonrasında da bir takım matematiksel hesaplamalar yaptırıyorum. Bu matematiksel hesaplamalar, aynı şekilde birbirini tekrar eden hesaplamalar. Bahse konu bu hesaplamaları ayrı bir makro ismiyle yazıp her satırda yeniden yazmak yerine "Call makroAdi" şeklinde çağırmaya çalıştım ama onu da başaramadım.

Bir diğer yapmak istediğim ise, Eğer B ve C sütunlarının değeri boşsa, Cells(satir, "E:F" & "O:X") içeriğinin silinmesini hedefledim. fakat yapamadım yine sonsuz döngü etkisinde kaldım sanıyorum.

Buraya yazmadan önce gerçekten çok fazla uğraştım ve denedim aklıma gelen yöntemleri ama başaramadım. Desteklerinizi rica ediyorum.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("B3:B10000")) Is Nothing Then
        sat = Target.Row
        If Cells(sat, "C") = Cells(sat, "B") * Range("B1") Then Exit Sub                                'Sonsuz döngüye girmemesi için yazdım
            If Cells(sat, "D") = "" Then Cells(sat, "D") = 1
            Cells(sat, "C") = Cells(sat, "B") * Range("B1")                                             'C Sütünunu CAD dönüştür
            
            'Buradan sonrası ortak işlemler
            Cells(sat, "E") = Cells(sat, "B") * Cells(sat, "D")                                         'E Sütununu Toplam dolar maliyetini yaz
            Cells(sat, "F") = Cells(sat, "E") * Range("B1")                                             'E Sütununu Kanada dolarına Çevir F sütununa yaz
            Cells(sat, "Q") = Cells(sat, "E") + Cells(sat, "K") + Cells(sat, "M")                       ' Q Sütununa Toplam USD maliyetini hesapla
            Cells(sat, "R") = Cells(sat, "Q") * Range("B1")                                             ' R Sütununa Toplam CAD maliyetine dönüştür
            Cells(sat, "O") = Cells(sat, "Q") / Cells(sat, "D")                                         ' O Sütununa Birim başına USD maliyetini hesapla (Toplam MAliyeti Adede böl
            Cells(sat, "P") = Cells(sat, "O") * Range("B1")                                             ' P Sütununa Birim başına CAD maliyetine dönüştür
            Cells(sat, "S") = Cells(sat, "G") - Cells(sat, "O") - Cells(sat, "I")                       ' S Sütununa Birim başına USD Marj tutarını hesapla
            Cells(sat, "T") = Cells(sat, "S") * Range("B1")                                             ' T Sütununa Birim başına CAD Marj tutarına dönüştür
            Cells(sat, "U") = Cells(sat, "S") * Cells(sat, "D")                                         ' S Sütununa Toplam USD Tahmini Marjını hesapla (Br. Marjı x Adet)
            Cells(sat, "V") = Cells(sat, "U") * Range("B1")                                             ' U Sütununa Toplam CAD Tahmini Marjına dönüştür
            Cells(sat, "W") = Cells(sat, "S") / Cells(sat, "G")                                         ' Marj rakamlarının yüzdelik oranlarını dönüştür
            Cells(sat, "X") = Cells(sat, "S") / Cells(sat, "O")                                         ' ROI hesapla
            Exit Sub
    Else
    If Not Intersect(Target, Range("C3:C10000")) Is Nothing Then
        sat = Target.Row
        If Cells(sat, "B") = Cells(sat, "C") * Range("D1") Then Exit Sub                                'Sonsuz Döngüye girmemesi için yazdım
            If Cells(sat, "D") = "" Then Cells(sat, "D") = 1
            Cells(sat, "B") = Cells(sat, "C") * Range("D1")                                             'B Sütünunu USD dönüştür
            
            'Buradan sonrası ortak işlemler
            Cells(sat, "E") = Cells(sat, "B") * Cells(sat, "D")                                         'E Sütununu Toplam dolar maliyetini yaz
            Cells(sat, "F") = Cells(sat, "E") * Range("B1")                                             'E Sütununu Kanada dolarına Çevir F sütununa yaz
            Cells(sat, "Q") = Cells(sat, "E") + Cells(sat, "K") + Cells(sat, "M")                       ' Q Sütununa Toplam USD maliyetini hesapla
            Cells(sat, "R") = Cells(sat, "Q") * Range("B1")                                             ' R Sütununa Toplam CAD maliyetine dönüştür
            Cells(sat, "O") = Cells(sat, "Q") / Cells(sat, "D")                                         ' O Sütununa Birim başına USD maliyetini hesapla (Toplam MAliyeti Adede böl
            Cells(sat, "P") = Cells(sat, "O") * Range("B1")                                             ' P Sütununa Birim başına CAD maliyetine dönüştür
            Cells(sat, "S") = Cells(sat, "G") - Cells(sat, "O") - Cells(sat, "I")                       ' S Sütununa Birim başına USD Marj tutarını hesapla
            Cells(sat, "T") = Cells(sat, "S") * Range("B1")                                             ' T Sütununa Birim başına CAD Marj tutarına dönüştür
            Cells(sat, "U") = Cells(sat, "S") * Cells(sat, "D")                                         ' S Sütununa Toplam USD Tahmini Marjını hesapla (Br. Marjı x Adet)
            Cells(sat, "V") = Cells(sat, "U") * Range("B1")                                             ' U Sütununa Toplam CAD Tahmini Marjına dönüştür
            Cells(sat, "W") = Cells(sat, "S") / Cells(sat, "G")                                         ' Marj rakamlarının yüzdelik oranlarını dönüştür
            Cells(sat, "X") = Cells(sat, "S") / Cells(sat, "O")                                         ' ROI hesapla
            Exit Sub
    Else
    If Not Intersect(Target, Range("E3:E10000")) Is Nothing Then
        sat = Target.Row
        If Cells(sat, "F") = Cells(sat, "E") * Range("B1") Then Exit Sub                                'Sonsuz döngüye girmemesi için yazdım
            If Cells(sat, "D") = "" Then Cells(sat, "D") = 1
            Cells(sat, "F") = Cells(sat, "E") * Range("B1")                                             'F Sütünunu CAD dönüştür
            
            'Buradan sonrası ortak işlemler
            Cells(sat, "E") = Cells(sat, "B") * Cells(sat, "D")                                         'E Sütununu Toplam dolar maliyetini yaz
            Cells(sat, "F") = Cells(sat, "E") * Range("B1")                                             'E Sütununu Kanada dolarına Çevir F sütununa yaz
            Cells(sat, "Q") = Cells(sat, "E") + Cells(sat, "K") + Cells(sat, "M")                       ' Q Sütununa Toplam USD maliyetini hesapla
            Cells(sat, "R") = Cells(sat, "Q") * Range("B1")                                             ' R Sütununa Toplam CAD maliyetine dönüştür
            Cells(sat, "O") = Cells(sat, "Q") / Cells(sat, "D")                                         ' O Sütununa Birim başına USD maliyetini hesapla (Toplam MAliyeti Adede böl
            Cells(sat, "P") = Cells(sat, "O") * Range("B1")                                             ' P Sütununa Birim başına CAD maliyetine dönüştür
            Cells(sat, "S") = Cells(sat, "G") - Cells(sat, "O") - Cells(sat, "I")                       ' S Sütununa Birim başına USD Marj tutarını hesapla
            Cells(sat, "T") = Cells(sat, "S") * Range("B1")                                             ' T Sütununa Birim başına CAD Marj tutarına dönüştür
            Cells(sat, "U") = Cells(sat, "S") * Cells(sat, "D")                                         ' S Sütununa Toplam USD Tahmini Marjını hesapla (Br. Marjı x Adet)
            Cells(sat, "V") = Cells(sat, "U") * Range("B1")                                             ' U Sütununa Toplam CAD Tahmini Marjına dönüştür
            Cells(sat, "W") = Cells(sat, "S") / Cells(sat, "G")                                         ' Marj rakamlarının yüzdelik oranlarını dönüştür
            Cells(sat, "X") = Cells(sat, "S") / Cells(sat, "O")                                         ' ROI hesapla
    Else
    If Not Intersect(Target, Range("F3:F10000")) Is Nothing Then
        sat = Target.Row
        If Cells(sat, "E") = Cells(sat, "F") * Range("D1") Then Exit Sub                                'Sonsuz döngüye girmemesi için yazdım
            If Cells(sat, "D") = "" Then Cells(sat, "D") = 1
            Cells(sat, "E") = Cells(sat, "F") * Range("D1")                                             'E Sütünunu USD dönüştür
            
            'Buradan sonrası ortak işlemler
            Cells(sat, "E") = Cells(sat, "B") * Cells(sat, "D")                                         'E Sütununu Toplam dolar maliyetini yaz
            Cells(sat, "F") = Cells(sat, "E") * Range("B1")                                             'E Sütununu Kanada dolarına Çevir F sütununa yaz
            Cells(sat, "Q") = Cells(sat, "E") + Cells(sat, "K") + Cells(sat, "M")                       ' Q Sütununa Toplam USD maliyetini hesapla
            Cells(sat, "R") = Cells(sat, "Q") * Range("B1")                                             ' R Sütununa Toplam CAD maliyetine dönüştür
            Cells(sat, "O") = Cells(sat, "Q") / Cells(sat, "D")                                         ' O Sütununa Birim başına USD maliyetini hesapla (Toplam MAliyeti Adede böl
            Cells(sat, "P") = Cells(sat, "O") * Range("B1")                                             ' P Sütununa Birim başına CAD maliyetine dönüştür
            Cells(sat, "S") = Cells(sat, "G") - Cells(sat, "O") - Cells(sat, "I")                       ' S Sütununa Birim başına USD Marj tutarını hesapla
            Cells(sat, "T") = Cells(sat, "S") * Range("B1")                                             ' T Sütununa Birim başına CAD Marj tutarına dönüştür
            Cells(sat, "U") = Cells(sat, "S") * Cells(sat, "D")                                         ' S Sütununa Toplam USD Tahmini Marjını hesapla (Br. Marjı x Adet)
            Cells(sat, "V") = Cells(sat, "U") * Range("B1")                                             ' U Sütununa Toplam CAD Tahmini Marjına dönüştür
            Cells(sat, "W") = Cells(sat, "S") / Cells(sat, "G")                                         ' Marj rakamlarının yüzdelik oranlarını dönüştür
            Cells(sat, "X") = Cells(sat, "S") / Cells(sat, "O")                                         ' ROI hesapla
    End If
    End If
    End If
    End If
End Sub

ToHaNS · Pazar saat 08:37'de

Konu güncel…

ÖmerBey · Pazar saat 09:15'de

Merhaba,
Application.EnableEvents = False koduyla tetiklemeyi iptal edersiniz. Sayfada değişiklik yapılan kod bloklarının başına bu satırı ekleyip sayfada işlem yaptırınız. Sonuna da Application.EnableEvents = True satırını ilave edip tekrar aktifleştiriniz. Böylece kod sayfada değişiklik yaptığında tetikleyiciler çalışmaz.

Muzaffer Ali · Pazar saat 17:31'de

Merhaba.
Dener misiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3:C" & Rows.Count & ",E3:F" & Rows.Count)) Is Nothing Then
        Application.EnableEvents = False
        
        If Cells(Target.Row, "D") = "" Then Cells(Target.Row, "D") = 1

        If Not Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "C") = Cells(Target.Row, "B") * Range("B1")
        ElseIf Not Intersect(Target, Range("C3:C" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "B") = Cells(Target.Row, "C") * Range("D1")
        ElseIf Not Intersect(Target, Range("E3:E" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "F") = Cells(Target.Row, "E") * Range("B1")
        ElseIf Not Intersect(Target, Range("F3:F" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "E") = Cells(Target.Row, "F") * Range("D1")
        End If
        
        If Not Cells(Target.Row, "G") = "" And Not Cells(Target.Row, "S") = "" Then
            Cells(Target.Row, "E") = Cells(Target.Row, "B") * Cells(Target.Row, "D")
            Cells(Target.Row, "F") = Cells(Target.Row, "E") * Range("B1")
            Cells(Target.Row, "Q") = Cells(Target.Row, "E") + Cells(Target.Row, "K") + Cells(Target.Row, "M")
            Cells(Target.Row, "R") = Cells(Target.Row, "Q") * Range("B1")
            Cells(Target.Row, "O") = Cells(Target.Row, "Q") / Cells(Target.Row, "D")
            Cells(Target.Row, "P") = Cells(Target.Row, "O") * Range("B1")
            Cells(Target.Row, "S") = Cells(Target.Row, "G") - Cells(Target.Row, "O") - Cells(Target.Row, "I")
            Cells(Target.Row, "T") = Cells(Target.Row, "S") * Range("B1")
            Cells(Target.Row, "U") = Cells(Target.Row, "S") * Cells(Target.Row, "D")
            Cells(Target.Row, "V") = Cells(Target.Row, "U") * Range("B1")
            Cells(Target.Row, "W") = Cells(Target.Row, "S") / Cells(Target.Row, "G")
            Cells(Target.Row, "X") = Cells(Target.Row, "S") / Cells(Target.Row, "O")
        End If
        Application.EnableEvents = True
    End If
End Sub

ToHaNS · Pazartesi saat 17:38'de

ÖmerBey' Alıntı:
Merhaba,
Application.EnableEvents = False koduyla tetiklemeyi iptal edersiniz. Sayfada değişiklik yapılan kod bloklarının başına bu satırı ekleyip sayfada işlem yaptırınız. Sonuna da Application.EnableEvents = True satırını ilave edip tekrar aktifleştiriniz. Böylece kod sayfada değişiklik yaptığında tetikleyiciler çalışmaz.

@ÖmerBey Hocam teşekkür ediyorum, bunu bilmiyordum ve öğrenmiş oldum. Büyük oranda sorunumu çözdü çok teşekkürler.

Muzaffer Ali' Alıntı:

Merhaba.
Dener misiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3:C" & Rows.Count & ",E3:F" & Rows.Count)) Is Nothing Then
        Application.EnableEvents = False
       
        If Cells(Target.Row, "D") = "" Then Cells(Target.Row, "D") = 1

        If Not Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "C") = Cells(Target.Row, "B") * Range("B1")
        ElseIf Not Intersect(Target, Range("C3:C" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "B") = Cells(Target.Row, "C") * Range("D1")
        ElseIf Not Intersect(Target, Range("E3:E" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "F") = Cells(Target.Row, "E") * Range("B1")
        ElseIf Not Intersect(Target, Range("F3:F" & Rows.Count)) Is Nothing Then
            Cells(Target.Row, "E") = Cells(Target.Row, "F") * Range("D1")
        End If
       
        If Not Cells(Target.Row, "G") = "" And Not Cells(Target.Row, "S") = "" Then
            Cells(Target.Row, "E") = Cells(Target.Row, "B") * Cells(Target.Row, "D")
            Cells(Target.Row, "F") = Cells(Target.Row, "E") * Range("B1")
            Cells(Target.Row, "Q") = Cells(Target.Row, "E") + Cells(Target.Row, "K") + Cells(Target.Row, "M")
            Cells(Target.Row, "R") = Cells(Target.Row, "Q") * Range("B1")
            Cells(Target.Row, "O") = Cells(Target.Row, "Q") / Cells(Target.Row, "D")
            Cells(Target.Row, "P") = Cells(Target.Row, "O") * Range("B1")
            Cells(Target.Row, "S") = Cells(Target.Row, "G") - Cells(Target.Row, "O") - Cells(Target.Row, "I")
            Cells(Target.Row, "T") = Cells(Target.Row, "S") * Range("B1")
            Cells(Target.Row, "U") = Cells(Target.Row, "S") * Cells(Target.Row, "D")
            Cells(Target.Row, "V") = Cells(Target.Row, "U") * Range("B1")
            Cells(Target.Row, "W") = Cells(Target.Row, "S") / Cells(Target.Row, "G")
            Cells(Target.Row, "X") = Cells(Target.Row, "S") / Cells(Target.Row, "O")
        End If
        Application.EnableEvents = True
    End If
End Sub

@Muzaffer Ali hocam, Verdiğiniz kodları kendime göre uyarladığımda çalışıyor. Alaka ve ilginize çok teşekkür ediyorum

Hücre Değeri Değişince Makro Çalışması ve Sonsuz Döngü Sorunu

ToHaNS

Ekli dosyalar

ToHaNS

ÖmerBey

Destek Ekibi

Muzaffer Ali

Destek Ekibi

ToHaNS