Aynı Sayfada İki Private Sub Makrosu

akhsahbaz · 20 Ocak 2008

Arkadaşlar, kod yazmayı bilmediğim için ihtiyacım olan kodları forumdan buluyorum. Aynı sayfada iki tane Private sub makrosu olduğundan kodlar çalışmıyor. Kodlar aşağıda veriyorum. İlginiz ve yardımlarınız için şimdiden teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range) 'Otomatik Sıralama Makrosu
On Error Resume Next
If Intersect(Target, [k3:k65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
Selection.Sort Key1:=Range("a3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Target.Offset(1, -10).Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A3]) Is Nothing Then Exit Sub
Set S2 = Sheets("Kontrol")
If Target <> "" Then
S2.[A4] = Target
S2.[A4].AutoFill Destination:=S2.[A4:A65536], Type:=xlFillDays
End If
Set S2 = Nothing
End Sub

karadami · 20 Ocak 2008

Bir koddaki private sub ve end sub satırlarını almadan diğerinin içine kopyalayarak dener misiniz lütfen.

akhsahbaz · 20 Ocak 2008

Önceden denedim fakat olmuyor.

mesuttasar · 20 Ocak 2008

Çalışma sayfanızda ne yapmak istiyorsunuz , onu söylerseniz yardımcı olabilirim belki.

akhsahbaz · 20 Ocak 2008

akhsahbaz' Alıntı:
Private Sub Worksheet_Change(ByVal Target As Range) 'Otomatik Sıralama Makrosu
On Error Resume Next
If Intersect(Target, [k3:k65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
Selection.Sort Key1:=Range("a3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Target.Offset(1, -10).Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A3]) Is Nothing Then Exit Sub
Set S2 = Sheets("Kontrol")
If Target <> "" Then
S2.[A4] = Target
S2.[A4].AutoFill Destination:=S2.[A4:A65536], Type:=xlFillDays
End If
Set S2 = Nothing
End Sub

1.Kod: Bulunduğu sayfanın k sütununda enter yapıldığında a sütununa göre A3 hücresinden başlayarak sıralatıyor.
2.Kod: Bulunduğu sayfanın A3 hücresine değer girildiğinde bu hücredeki tarihi önce "Kontrol" sayfasının A4 hücresine kopyalıyor, sonrada buradanda sütun sonuna kadar(A65536) sıralatıyor.

Skorpiyon · 20 Ocak 2008

Sayın akhsahbaz,

Aşağıdaki şekilde bir dener misiniz ?

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [k3:k65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
Selection.Sort Key1:=Range("a3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
If Intersect(Target, [A3]) Is Nothing Then Exit Sub
Set S2 = Sheets("Kontrol")
If Target <> "" Then
S2.[A4] = Target
S2.[A4].AutoFill Destination:=S2.[A4:A65536], Type:=xlFillDays
End If
Set S2 = Nothing
End Sub

hsayar · 20 Ocak 2008

Kod:

Private Sub Worksheet_Change(ByVal Target As Range) 'Otomatik S&#305;ralama Makrosu
On Error Resume Next
If Intersect(Target, [A3:A65536,k3:k65536]) Is Nothing Then Exit Sub

if target.coloumn = 11 then 
If Target.Value = "" Then Exit Sub
Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
Selection.Sort Key1:=Range("a3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Target.Offset(1, -10).Select

elseif target.coloumn = 1 then 

'____________
Set S2 = Sheets("Kontrol")
If Target <> "" Then
S2.[A4] = Target
S2.[A4].AutoFill Destination:=S2.[A4:A65536], Type:=xlFillDays
End If
end if
Set S2 = Nothing
End Sub

olarak denermisiniz ben denemedim ama mantık bu şekilde

akhsahbaz · 20 Ocak 2008

Sn.Sertkaya ve Sn.hsayar ilginiz için teşekkür ederim. Her iki kod da malesef olmadı. Sn.hsayar ın ilk End Sub da hata veriyor.

hsayar · 20 Ocak 2008

ilk end subu silin benim gözümden kaçmış oda olmazsa dosyayı ekleyiniz

akhsahbaz · 20 Ocak 2008

Silincede kod malesef çalışmıyor Sn.hsayar.

Skorpiyon · 20 Ocak 2008

Sayın akhsahbaz,

Dosyanız özel değil ise ekler misiniz.

akhsahbaz · 20 Ocak 2008

Dosyayı yeniden düzenleyip konuyu anlatmaya çalıştım.

Skorpiyon · 20 Ocak 2008

İyi de Sayın akhsahbaz,

Sizin bu kodlarınızın olduğu bölüm neresi ? Ben mi göremiyorum ???

Dosyayı buraya eklediğiniz haliyle bende normal açılıyor ve hiçbir hata vermiyor. Zira bahsettiğiniz sayfa kodları yok. Hata veren bölümü eklemelisiniz ki orayı düzeltelim.

Zeki Gürsoy · 20 Ocak 2008

Bunu deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next

    If Intersect(Target, [k3:k65536]) Then
        If Target.Value = "" Then Exit Sub
        Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
        Selection.Sort Key1:=Range("a3"), _
            Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        Target.Offset(1, -10).Select
    
    ElseIf Target.Address = "$A$3" Then
        Set S2 = Sheets("Kontrol")
        If Target.Value <> "" Then
            S2.[A4] = Target.Value
            S2.[A4].AutoFill Destination:=S2.[A4:A65536], _
                Type:=xlFillDays
        End If
        Set S2 = Nothing
    End If
    
End Sub

akhsahbaz · 20 Ocak 2008

Sn.Sertkaya, ben o kodlarıda birlikte olduğu zaman çalışmadığı için silmiştim. Kodlar 1.sayfada yani "Form" adlı sayfada duruyorlardı.
Buarada Sn.anemos ilginiz için teşekkür ederim ama bu kodda çalışmıyor.

Skorpiyon · 20 Ocak 2008

Sayın akhsahbaz,

Private Sub Worksheet_Change(ByVal Target As Range) 'Otomatik Sıralama Makrosu
On Error Resume Next
If Intersect(Target, [k3:k65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Range(Cells(3, "a"), Cells(Target.Row, "k")).Select
Selection.Sort Key1:=Range("a3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Target.Offset(1, -10).Select
If Intersect(Target, [A3]) Is Nothing Then Exit Sub
Set S2 = Sheets("Kontrol")
If Target <> "" Then
S2.[A4] = Target
S2.[A4].AutoFill Destination:=S2.[A4:A65536], Type:=xlFillDays
End If
Set S2 = Nothing
End Sub

Kodları aynen bu şekilde denedim ve hiç bir hata vermedi.
Not : Kodların (ilk mesajda yazdığı halde) Form sayfasında olduğunu bir anlık düşünemeden mesaj yazdığım için kusura bakmayın.

hsayar · 20 Ocak 2008

1.Kod: Bulunduğu sayfanın k sütununda enter yapıldığında a sütununa göre A3 hücresinden başlayarak sıralatıyor.

2.Kod: Bulunduğu sayfanın A3 hücresine değer girildiğinde bu hücredeki tarihi önce "Kontrol" sayfasının A4 hücresine kopyalıyor, sonrada buradanda sütun sonuna kadar(A65536) sıralatıyor.

benim verdiğim kodlarda bu işi yapıyor ama sayfa2 ye kopyalamıyor çünkü bu kod satırı (.copy içeren satır) yok.

siz amacınız tam olarak tekrar izah ediniz ona göre yeni bir çözüm denensin.

akhsahbaz · 20 Ocak 2008

Sn.Sertkaya ben kodu denedim bende çalışmıyor. Eğer zahmet olmazsa bana kodu çalıştırmış olduğunuz çalışmayı gönderirseniz sevinirim.

Skorpiyon · 20 Ocak 2008

Sayın akhsahbaz,

Ben öncelikle sizde ne tür bir hataya sebep olduğunu sorarak, dosyayı ekleyeyim.

Ben sadece açılışta direkt hata mesajı aldığınızı varsayarak hata yok dedim. Eğer Sayın hsayar'ın dediği gibi kopyalama vs. işlemini yapmıyorsa kodları o kadar detaylı incelemediğimi belirtmek isterim.

akhsahbaz · 20 Ocak 2008

Sn.hsayar,

1.Kod: Bulunduğu sayfanın k sütununda herhangi bir hücreye enter yapıldığında a sütunundaki tarihler küçükten büyüğe doğru A3 hücresinden başlayarak sıralatıyor.(Kod Enter ile çalışıyor)

2.Kod: Bulunduğu sayfanın("Form") A3 hücresine değer(tarih) girildiğinde bu hücredeki tarihi önce "Kontrol" sayfasının A4 hücresine kopyalıyor, sonrada "Kontrol" sayfası A4 hücresindeki tarihden otomatik olarak sütunun sonuna kadar(A65536) tarih sıralatıyor. (Kod "Form" sayfasının A3 Hücresine değer girilmesi ile çalışıyor)

Aynı Sayfada İki Private Sub Makrosu

akhsahbaz

karadami

akhsahbaz

mesuttasar

akhsahbaz

Skorpiyon

Misafir

hsayar

akhsahbaz

hsayar

akhsahbaz

Skorpiyon

Misafir

akhsahbaz

Skorpiyon

Misafir

Zeki Gürsoy

Uzman

akhsahbaz

Skorpiyon

Misafir

hsayar

akhsahbaz

Skorpiyon

Misafir

akhsahbaz