Döngüye Giren Formüller Hakkında

[oguzhan5334]

Merhabalar;
İş yerinde hazırladığım hesap şablonum var ve birbirine bağlı ardışık kompleks mühendislik hesapları ile çalışmaktadır.Bu hesaplamalarda manuel olarak veri çektiğim bir kısım var ki bu benim ciddi anlamda zamanımı almaktadır. Bunu otomatikleştirmem gerekmekte detaylarını aşağıda paylaşıyorum. Şimdiden yardımlarınız için teşekkürler.

Manuel yaptığım işlem şu şekilde;

1. A1 hücresine veri girdiğimde K1 - L1 -M1 - N1 - O1 hücrelerindeki formüller devreye giriyor ve hesap yaparak bu hücrelerde sayılar çıkıyor.
2. K1 - L1 -M1 - N1 - O1 hücrelerinde çıkan sayıları alıp önce bir alt satıra kıyaslama yapmak için sayı olarak yapıştırıyorum.
3. Yine alt satıra yapıştırdığım sayıları kopyalayıp B1-C1-D1-E1-F1 hücresine yapıştırıyorum.
4.B1-C1-D1-E1-F1 hücresine gelen verilere bağlı olarak K1 - L1 -M1 - N1 - O1 hücresindeki veriler değişmektedir.
5. K1 - L1 -M1 - N1 - O1 değişen hücre verilerinin alta yapıştırdığım hücredeki veriler ile aynı mı diye karşılaştırıyorum.
6. Eğer sayılar aynı değilse K1 - L1 -M1 - N1 - O1 hücresindeki verileri kopyalayıp B1-C1-D1-E1-F1 e tekrar yazıyorum. Tekrar kıyaslama yapıyorum.Bu işlemi aynı sayılar gelene kadar tekrarlıyorum.
7. En sonunda K1 - L1 -M1 - N1 - O1 ve B1-C1-D1-E1-F1 aynı oluyor. (max. 3. seferde).


Eğer ben B1-C1-D1-E1-F1 'yi K1 - L1 -M1 - N1 - O1 'e eşittir ile formüllersem döngü oluyor otomatik yapamıyorum.

Yukarıda 7 adımda yaptığım işlemi formüllerle sırası ile nasıl otomatikleştiririm yardımcı olursanız çok sevinirim.

 

[Mahir64]

Merhaba,

1. A1 hücresine veri girdiğimde K1 - L1 -M1 - N1 - O1 hücrelerindeki formüller devreye giriyor ve hesap yaparak bu hücrelerde sayılar çıkıyor.

4.B1-C1-D1-E1-F1 hücresine gelen verilere bağlı olarak K1 - L1 -M1 - N1 - O1 hücresindeki veriler değişmektedir.

Yazarken "Döngüsel Başvuru" olmuş.

Nasıl oluyor.

K1 - L1 -M1 - N1 - O1

hücresindeki formülleri A1 hücresine veri girince tetikleniyorsa,

B1-C1-D1-E1-F1

hücresine gelen verilere göre

K1 - L1 -M1 - N1 - O1

hücreleri nasıl değişiyor.

Başım döndü resmen.

 

[oguzhan5334]

Merhaba,




Yazarken "Döngüsel Başvuru" olmuş.

Nasıl oluyor. hücresindeki formülleri A1 hücresine veri girince tetikleniyorsa,
hücresine gelen verilere göre hücreleri nasıl değişiyor.

Başım döndü resmen.

Döngüye girmemesi için bu işlemleri manuel olarak yapıyorum. Formüllerim çok karışık şöyle söyleyeyim;

A1 hücresinde benim ara dağıtım borularımın ısı kapasitesi var. Bu metraja göre K1 - L1 -M1 - N1 - O1 hücresinde ana hat borularımın çaplandırılması belli aralığa göre sınıflandırma yapılarak hücrelere geliyor. örnek (DN50 boru 5 metre , DN65 15 şeklinde ....devam ediyor.)

Gelen bu verileri alıp B1-C1-D1-E1-F1 e yazdığımda o borulardan da gelen ısıyı hesaba katarak sistemin toplam kapasitesine göre yeniden çaplandırma yapıyorum olay bu. İşlem sırası yukarıdaki gibi yaptırabilirsem sorunum çözülecek.

İnşallah anlatabilmişimdir.

 

[Mahir64]

İşlem sırasını bilmediğim ve dosya yapınızı görmediğim için kafanda tasvir edemedim.
Örnek ekleyebilir misiniz?

 

[oguzhan5334]

İşlem sırasını bilmediğim ve dosya yapınızı görmediğim için kafanda tasvir edemedim.
Örnek ekleyebilir misiniz?

Formülle ve sayılar orjinalinden farklı olsada mantık aynı. Yukarıdaki adımları sırası ile uygulayın belki 6 ve 7 nolu adımdaki sonuçlar belki çıkmayacak bu örnekte ama orjinalinde sayılar aynı çıkmakta.

https://s4.dosya.tc/server9/kvo4m7/Kitap1.xlsx.html

 

[YUSUF44]

Do Loop Until olayıyla çözmeye çalıştım ancak kodlar K:O arasındaki formüllerdeki "" sorunu nedeniyle sonuca ulaşmıyor. Çünkü bu değer hücrenin matematiksel işlemlerde hata vermesine neden oluyor. Bu işaretler yerine 0 yazınca aşağıdaki kodlar A1 hücresinin her değişiminde istediğiniz işlemi yapıyor. Sonsuz döngüye girmemesi için bu işlemin 10 kereden fazla olmaması için de düzenleme yaptım. Kodları ilgili sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırmanız gerekiyor:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
a = 0

If [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Then
    Exit Sub
Else
    Do
        [K1:O1].Copy: [B1].PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

 

[oguzhan5334]

Do Loop Until olayıyla çözmeye çalıştım ancak kodlar K:O arasındaki formüllerdeki "" sorunu nedeniyle sonuca ulaşmıyor. Çünkü bu değer hücrenin matematiksel işlemlerde hata vermesine neden oluyor. Bu işaretler yerine 0 yazınca aşağıdaki kodlar A1 hücresinin her değişiminde istediğiniz işlemi yapıyor. Sonsuz döngüye girmemesi için bu işlemin 10 kereden fazla olmaması için de düzenleme yaptım. Kodları ilgili sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırmanız gerekiyor:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
a = 0

If [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Then
    Exit Sub
Else
    Do
        [K1:O1].Copy: [B1].PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

Örnek excel olduğu için "" koydum normalde orada sayılar var.

 

[oguzhan5334]

Do Loop Until olayıyla çözmeye çalıştım ancak kodlar K:O arasındaki formüllerdeki "" sorunu nedeniyle sonuca ulaşmıyor. Çünkü bu değer hücrenin matematiksel işlemlerde hata vermesine neden oluyor. Bu işaretler yerine 0 yazınca aşağıdaki kodlar A1 hücresinin her değişiminde istediğiniz işlemi yapıyor. Sonsuz döngüye girmemesi için bu işlemin 10 kereden fazla olmaması için de düzenleme yaptım. Kodları ilgili sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırmanız gerekiyor:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
a = 0

If [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Then
    Exit Sub
Else
    Do
        [K1:O1].Copy: [B1].PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until [B1] = [K1] And [C1] = [L1] And [D1] = [M1] And [E1] = [N1] And [F1] = [O1] Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

Ayrıca ben bu işlemi diğer satırlara da uygulatmak istiyorum bunu nasıl yaptırabilirim ?

 

[YUSUF44]

Diğer satırlara uygualamaktan kastınız nedir? Lütfen sorunuzu tam olarak istediğinizi gösterecek şekilde sorun.

 

[oguzhan5334]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
a = 0

If [D5] = [AF30] And [E5] = [AG30] And [F5] = [AH30] And [G5] = [AI30] And [H5] = [AJ30] And [I5] = [AK30] Then
    Exit Sub
Else
    Do
        [AF30:AK30].Copy: [D5].PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until [D5] = [AF30] And [E5] = [AG30] And [F5] = [AH30] And [G5] = [AI30] And [H5] = [AJ30] And [I5] = [AK30] Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

Şimdi yaptığınız kodu dosyama göre yazdığımda yukarıdaki gibi oldu ve çalıştı . Ama şöyle bir durum var ;
"C5" değiştiği zaman makro süper çalışıyor. Benim C5 hücremdeki veri sabit ama AF30:AK30 arasındaki verileri değiştiren başka verilere bağlı eğerli formüllerim var. Sayılar eşitlendikten AF30:AK30 i etkileyen diğer formüllerle işlem yaptığımda AF30:AK30 değişiyor. Bu değişiklik olması durumunda da makroyu tekrar çalıştırsın istiyorum.

Diğer satırlara uygualamaktan kastınız nedir?
Resimdede göreciğiniz gibi aynı makro kodundaki hücreleri değiştirip 6. 7. 8..... şeklinde alt satırlarada uygulacağım. Kod görüntüle diyince aynı makro kodunu alt alta yapıştırıp hücreleri değiştirince çalışacak mıdır ?
https://resimyukle.xyz/i/BPVd47

 

[YUSUF44]

Aşağıdaki gibi deneyin. C5:C1000 arasında çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C1000]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
b = Target.Row
a = 0

If Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Then
    Exit Sub
Else
    Do
        Range("AF" & b + 25 & ":AK" & b + 25).Copy: Cells(b, "D").PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

 

[oguzhan5334]

Aşağıdaki gibi deneyin. C5:C1000 arasında çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C1000]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
b = Target.Row
a = 0

If Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Then
    Exit Sub
Else
    Do
        Range("AF" & b + 25 & ":AK" & b + 25).Copy: Cells(b, "D").PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

Peki bunu nasıl yaptırabiliriz.

Benim C5 hücremdeki veri sabit ama AF30:AK30 arasındaki verileri değiştiren başka verilere bağlı eğerli formüllerim var. Sayılar eşitlendikten AF30:AK30 i etkileyen diğer formüllerle işlem yaptığımda AF30:AK30 değişiyor. Bu değişiklik olması durumunda da makroyu tekrar çalıştırsın istiyorum.

 

[YUSUF44]

Aşağıdaki gibi dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C1000, AF30:AK1025]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
b = Target.Row
If Target.Column >= 32 Then b = b - 25
a = 0
If Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Then
    Exit Sub
Else
    Do
        Range("AF" & b + 25 & ":AK" & b + 25).Copy: Cells(b, "D").PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

 

[oguzhan5334]

Aşağıdaki gibi dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C1000, AF30:AK1025]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
b = Target.Row
If Target.Column >= 32 Then b = b - 25
a = 0
If Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Then
    Exit Sub
Else
    Do
        Range("AF" & b + 25 & ":AK" & b + 25).Copy: Cells(b, "D").PasteSpecial Paste:=xlValues
        a = a + 1
    Loop Until Cells(b, "D") = Cells(b + 25, "AF") And Cells(b, "E") = Cells(b + 25, "AG") And Cells(b, "F") = Cells(b + 25, "AH") And Cells(b, "G") = Cells(b + 25, "AI") And Cells(b, "H") = Cells(b + 25, "AJ") And Cells(b, "I") = Cells(b + 25, "AK") Or a > 10
End If
If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"
End Sub

Maalesef AF30:AK30 değişmesi durumunda makro baştan çalışmıyor.

 

[YUSUF44]

Dosyanızı buna uygun olarak paylaşır mısınız?

 

[oguzhan5334]

Dosyanızı buna uygun olarak paylaşır mısınız?

Özelden mail yolladım.

 

[oguzhan5334]

YUSUF44 'e yardımlarından dolayı çok teşekkür ederim.

 

[oguzhan5334]

Dosyanızı buna uygun olarak paylaşır mısınız?

s.a ustam bakma fırsatın oldumu

 

[YUSUF44]

Aşağıdaki kodu dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C15]) Is Nothing Then GoTo 10
If Selection.Count > 1 Then Exit Sub
sat = Target.Row
sut = (sat - 1) * 8
If Target = "" Then
    Range("D" & sat & ":I" & sat).ClearContents
    Exit Sub
End If
a = 0

If Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
    And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Then
    Exit Sub
Else
    Application.ScreenUpdating = False
        Do
            Range(Cells(30, sut), Cells(30, sut + 5)).Copy: Cells(sat, "D").PasteSpecial Paste:=xlValues
            a = a + 1
        Loop Until Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
            And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Or a > 10
    Application.ScreenUpdating = True
End If

10:
If Intersect(Target, [AL4:DN4]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
sat = Target.Row + 1
sut = Target.Column - 6
[D1] = sat
[E1] = sut

Cells(1, sut) = Target.Column + 2 Mod 8
If Target.Column + 2 Mod 8 <> 0 Then Exit Sub

a = 0

If Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
    And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Then
    Exit Sub
Else
    Application.ScreenUpdating = False
        Do
            Range(Cells(30, sut), Cells(30, sut + 5)).Copy: Cells(sat, "D").PasteSpecial Paste:=xlValues
            a = a + 1
        Loop Until Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
            And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Or a > 10
    Application.ScreenUpdating = True
End If

If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"

End Sub

 

[oguzhan5334]

Aşağıdaki kodu dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C5:C15]) Is Nothing Then GoTo 10
If Selection.Count > 1 Then Exit Sub
sat = Target.Row
sut = (sat - 1) * 8
If Target = "" Then
    Range("D" & sat & ":I" & sat).ClearContents
    Exit Sub
End If
a = 0

If Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
    And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Then
    Exit Sub
Else
    Application.ScreenUpdating = False
        Do
            Range(Cells(30, sut), Cells(30, sut + 5)).Copy: Cells(sat, "D").PasteSpecial Paste:=xlValues
            a = a + 1
        Loop Until Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
            And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Or a > 10
    Application.ScreenUpdating = True
End If

10:
If Intersect(Target, [AL4:DN4]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
sat = Target.Row + 1
sut = Target.Column - 6
[D1] = sat
[E1] = sut

Cells(1, sut) = Target.Column + 2 Mod 8
If Target.Column + 2 Mod 8 <> 0 Then Exit Sub

a = 0

If Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
    And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Then
    Exit Sub
Else
    Application.ScreenUpdating = False
        Do
            Range(Cells(30, sut), Cells(30, sut + 5)).Copy: Cells(sat, "D").PasteSpecial Paste:=xlValues
            a = a + 1
        Loop Until Cells(sat, "D") = Cells(30, sut) And Cells(sat, "E") = Cells(30, sut + 1) And Cells(sat, "F") = Cells(30, sut + 2) _
            And Cells(sat, "G") = Cells(30, sut + 3) And Cells(sat, "H") = Cells(30, sut + 4) And Cells(sat, "I") = Cells(30, sut + 5) Or a > 10
    Application.ScreenUpdating = True
End If

If a > 10 Then MsgBox "10 denemede sonuca ulaşılamadğından işlem sonlandırıldı!"

End Sub

Diğer hücreler için çalıştı ama hatırlarsanız AL4 hücresi değiştirildiğinde formüller baştan çalışıyordu bu yazdığınız formülde o işlemi şu an yapmıyor.