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

[YUSUF44]

Makro aşağıdaki gibi daha doğru oldu ama maalesef belirttiğiniz gibi 4. satırdaki değişiklikleri dikkate almıyor. Daha doğrusu 30. satırı kopyalayıp ilgili yere yapıştırma döngüsünü işletmiyor. Nedenini çözemedim. Başka arkadaşlar umarım çözüm bulurlar:

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
sut = Target.Column - 6
sat = sut / 8 + 1
'[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]

Yardımcı olabilecek arkadaşlar mesaj atabilir mi?

 

[YUSUF44]

Aşağıdaki gibi düzeldi. Nedense koddaki mod alma işlemi düzgün çalışmıyordu. Ben de 1. satırda bir hücreye formülle mod alma işlemi yaptırdım:

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
sut = Target.Column - 6
sat = (Target.Column + 2) / 8

'[D1] = sat Makronun nerde hata yaptığını bulmak için eklemiştim
'[E1] = sut Makronun nerde hata yaptığını bulmak için eklemiştim

Cells(1, sut).FormulaR1C1 = "=MOD(COLUMN(R[3]C[6])+2,8)" 'Bu kısım makronun mod alma işlemini düzgün yapması için
If Cells(1, sut) <> 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
        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
End If

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

End Sub

 

[oguzhan5334]

Eline sağlık üstadım. Makro çalıştırma için birkaç soru olacak size;

1. Aynı sayfa içinde birden çok makroyu çalıştıramıyoruz kodların değişmesi lazım demiştiniz . Şöyle bir şey yapsam bu kod çalışır mı?

Biz bu kodu 11 satır için yazdırdık ya , benim bu 11 satırdan hariç aynı sayfada buna benzer hesaplarım var ve işlem sırası tamamen aynı. ( satır numaraları 100 lerde aralarda başka işlemlerim var,sıralı gitmiyor yani.)

Ben bu işlemi yaptıracağım hücreleri başka sayfaya = ile çeksem ve o sayfada makroyu kod görüntüleye koysam. Daha sonra ana sayfada verileri değiştirsem makro o sayfaya gitmeden çalışır mı ?

 

[YUSUF44]

Kodda C5:C15 aralığı ve AL4N4 aralığı için iki ayrı işlem yaptırıyoruz. İsterseniz M55:N102 ya da AK130:BB150 gibi değişik yerler için de değişik düzenlemeler yapılabilir. Bunun için hangi şartlarda hangi hücrelerde ne yapılacağını açıkça belirtin.

 

[oguzhan5334]

Ben sizi yormak istemiyorum şöyle bir örnek ile anlatayım.
1. nolu sayfamda bu makro olsun ve C5:C15 için çalışıyor. Benim C15 ten sonra C40 arasında metin yazı vs var.
örnek olarak C41:C45 arasında C5:C15 'te yaptığımız işlemi yaptırmam gerekecek. Ama makro bu hücrelere uygun değil ve makrom çalışmayacak.

Bundan sonrası için;
C41:C45 teki verileri = ile "deneme" adlı sayfaya çektiğimi ve deneme adlı sayfada C5:C15 'e yazdırayım. Yukarıdaki makroyuda deneme adlı sayfamın kod kısmına ekleyeyim.

1. sayfaya döndüğümde ben C41:C45 e veri girdiğimde deneme sayfamdaki makro çalışır mı? Şayet çalışırsa zaten verileri = ile formüllediğim için 1. sayfaya çekecektir. Bunu anlatmak istedim.

 

[YUSUF44]

Çalışmaz. Çalışması için makroda C41:C45 arası için de ayrı düzenleme yapılmalıdır.

 

[oguzhan5334]

Çalışmaz. Çalışması için makroda C41:C45 arası için de ayrı düzenleme yapılmalıdır.

Anladım , şirkettekilerle görüşeyim profesyonel destek aldıralım yoksa buradan sizi de yorarız anlatmak istediklerim bu kadarla sınırlı değil.Çok daha fazlası var dosya paylaşamadığım için yüz yüze görüşmeden de çözülmez.

Emekleriniz için teşekkür ederim.

 

[oguzhan5334]

@YUSUF44 Hocam yavaştan makro öğrenmeye başlıyorumda aklıma söyle bir şey geldi. Bizim makro sayfamız Change durumunda herhangi bir değişiklik olunca makro çalışıyor otomatik. Bunun yerine ben her satırın kenarına buton koyarak makro atasam ve tıkladığımda o satır için makro çalışsa olur mu ?

 

[YUSUF44]

Olur ama kullanışlı olmaz. Her satır için ayrı düğme yerine tek makro ve tek düğmeyle seçili satırda işlem yaptırmak daha mantıklı ve pratik olur.

 

[oguzhan5334]

Nasıl yapılacağına dair adım sırasını belirtirseniz kodları vs ben arayıp bulup, kendim yazmayı deneyeyim.

 

[YUSUF44]

Aşağıdaki makro seçili olan hücrenin yerine göre işlem yapar. Ancak bu kodu mevcut dosyanıza göre düzenledim. Eğer daha önce bahsettiğiniz gibi aşağıya doğru başka bloklar hazırlayacaksanız hatalı sonuçlar verebilir. Dosyanızın o haliyle de kullanmak istiyorsanız o halini de paylaşmanız gerekir ki düzenleme yapabilelim:

Sub denemeler()
If ActiveCell.Column = 3 Then
    sat = ActiveCell.Row
    sut = (sat - 1) * 8
ElseIf ActiveCell.Column >= 31 Then
    yer = ActiveCell.Column Mod 8
    If yer = 7 Then
        sut = ActiveCell.Column + 1
    Else
        sut = ActiveCell.Column - yer
    End If
    sat = sut / 8 + 1
Else
    MsgBox "Lütfen işlem yapılabilecek alanda bir hücre seçiniz!"
    Exit Sub
End If

a = 0
If ActiveCell.Column = 3 Then
    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

ElseIf ActiveCell.Column >= 31 Then

    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
        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
    End If

End If

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

End Sub

 

[oguzhan5334]

@YUSUF44 Hocam teşekkür ettim yaptığınızda güzel oldu. Ben bahsettiğim gibi aşağıdaki her satıra şöyle makro yaptım. Bunuda butona bağladım, butona bastığımda makro çalışıyor.

Sub Ray_4()
    Range("BG30:BL30").Select
    Selection.Copy
    Range("G8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BG30:BL30").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("BG30:BL30").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub