• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

O

oguzhan5334

Katılım
9 Haziran 2010
Mesajlar
49
Excel Vers. ve Dili
2003 türkçe
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.
 
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.
Genişletmek için tıkla ...
4.B1-C1-D1-E1-F1 hücresine gelen verilere bağlı olarak K1 - L1 -M1 - N1 - O1 hücresindeki veriler değişmektedir.
Genişletmek için tıkla ...

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

Nasıl oluyor.
K1 - L1 -M1 - N1 - O1
Genişletmek için tıkla ...
hücresindeki formülleri A1 hücresine veri girince tetikleniyorsa,
B1-C1-D1-E1-F1
Genişletmek için tıkla ...
hücresine gelen verilere göre
K1 - L1 -M1 - N1 - O1
Genişletmek için tıkla ...
hücreleri nasıl değişiyor.

Başım döndü resmen.
 
Mahir ÇÜMEN' Alıntı:
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.
Genişletmek için tıkla ...

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.
 
İşlem sırasını bilmediğim ve dosya yapınızı görmediğim için kafanda tasvir edemedim.
Örnek ekleyebilir misiniz?
 
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:

PHP: 
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
 
YUSUF44' Alıntı:
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:

PHP: 
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
Genişletmek için tıkla ...
Örnek excel olduğu için "" koydum normalde orada sayılar var.
 
YUSUF44' Alıntı:
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:

PHP: 
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
Genişletmek için tıkla ...
Ayrıca ben bu işlemi diğer satırlara da uygulatmak istiyorum bunu nasıl yaptırabilirim ?
 
Diğer satırlara uygualamaktan kastınız nedir? Lütfen sorunuzu tam olarak istediğinizi gösterecek şekilde sorun.
 
Kod: 
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
 
Aşağıdaki gibi deneyin. C5:C1000 arasında çalışır:

PHP: 
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
 
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin. C5:C1000 arasında çalışır:

PHP: 
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
Genişletmek için tıkla ...
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.
 
Aşağıdaki gibi dener misiniz?

PHP: 
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
 
YUSUF44' Alıntı:
Aşağıdaki gibi dener misiniz?

PHP: 
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
Genişletmek için tıkla ...
Maalesef AF30:AK30 değişmesi durumunda makro baştan çalışmıyor.
 
Dosyanızı buna uygun olarak paylaşır mısınız?
 
Aşağıdaki kodu dener misiniz?

PHP: 
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
 
YUSUF44' Alıntı:
Aşağıdaki kodu dener misiniz?

PHP: 
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
Genişletmek için tıkla ...
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst