Makroda hücreden onay alma problemi

[ates_2001]

İyi günler,

Gönderdiğim ekte 2 adet aynı mantıkta makro var, 1) aktarim_yap 2) loopcheck makroları. J4 hücresinde atalı olan "aktarim_yap" makrosundan "sayfa2" deki verileri alacağım zaman onay alıp verileri alıyor, lakin "K4" hücresine atalı olan "loopcheck" makrosundan "loop check wtp" doyasının verilerini alacağım zaman onay istemiyor bu yüzden geliştiriciden makroyu çalıştırarak verileri alıyorum.

Sorum şu K4 hücresinde de J4 hücresi gibi onay istemesini istiyorum.

Teşekkürler, İyi Çalışmalar

 

[mancubus]

Loop Check WTP sayfasındaki kodları silin

AKT-3 sayfasındaki kodları silin ve yerine

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("J4")) Is Nothing Then
        Call aktarim_yap
    ElseIf Not Intersect(Target, Range("K4")) Is Nothing Then
        Call loopcheck
    Else
        Exit Sub
    End If

End Sub

 

[mancubus]

kodlarınızı aşağıdaki gibi indented (girintili) yazarsanız okumak ve yorumlamak daha kolay olur ve çözüm az zaman alır.

Sub loopcheck()

Dim c As Range, sat As Long, ilkadres As Variant

a = MsgBox("Aktarim'a Basliyayim Mi_?", vbYesNo + vbInformation, "Onay")
If a = vbNo Then
Else
    Sheets("AKT-3").Range("B18:H" & Rows.Count).ClearContents
    sat = 18
    With Sheets("Loop Check WTP").Range("A:A")
        Set c = .Find(Sheets("AKT-3").Range("K4"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Sheets("AKT-3").Cells(sat, "B") = Sheets("Loop Check WTP").Cells(c.Row, "A")
                Sheets("AKT-3").Cells(sat, "C") = Sheets("Loop Check WTP").Cells(c.Row, "B")
                Sheets("AKT-3").Cells(sat, "D") = Sheets("Loop Check WTP").Cells(c.Row, "C")
                Sheets("AKT-3").Cells(sat, "E") = Sheets("Loop Check WTP").Cells(c.Row, "D")
                Sheets("AKT-3").Cells(sat, "F") = Sheets("Loop Check WTP").Cells(c.Row, "E")
                Sheets("AKT-3").Cells(sat, "G") = Sheets("Loop Check WTP").Cells(c.Row, "F")
                Sheets("AKT-3").Cells(sat, "H") = Sheets("Loop Check WTP").Cells(c.Row, "G")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    MsgBox UCase(Sheets("AKT-3").Range("K4")) & "'ler Aktarildi", vbInformation, "Bitis"
End If

End Sub

Sub aktarim_yap()

Dim c As Range, sat As Long, ilkadres As Variant

a = MsgBox("Aktarim'a Basliyayim Mi_?", vbYesNo + vbInformation, "Onay")
If a = vbNo Then
Else
    Sheets("AKT-3").Range("B18:H" & Rows.Count).ClearContents
    sat = 18
    With Sheets("Sayfa2").Range("A:A")
        Set c = .Find(Sheets("AKT-3").Range("J4"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Sheets("AKT-3").Cells(sat, "B") = Sheets("Sayfa2").Cells(c.Row, "A")
                Sheets("AKT-3").Cells(sat, "C") = Sheets("Sayfa2").Cells(c.Row, "B")
                Sheets("AKT-3").Cells(sat, "D") = Sheets("Sayfa2").Cells(c.Row, "C")
                Sheets("AKT-3").Cells(sat, "E") = Sheets("Sayfa2").Cells(c.Row, "D")
                Sheets("AKT-3").Cells(sat, "F") = Sheets("Sayfa2").Cells(c.Row, "E")
                Sheets("AKT-3").Cells(sat, "G") = Sheets("Sayfa2").Cells(c.Row, "F")
                Sheets("AKT-3").Cells(sat, "H") = Sheets("Sayfa2").Cells(c.Row, "G")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    MsgBox UCase(Sheets("AKT-3").Range("J4")) & "'ler Aktarildi", vbInformation, "Bitis"
End If

End Sub

 

[ates_2001]

Teşekkürler, ellerinize sağlık

 

[mancubus]

rica ederim.
kolay gelsin.