2 ayrı macro kodu aynı sayfa üzerinde çalıştırma ?

aykut12344 · 22 Eylül 2013

arkadaşlar iki tane macro kodu yazdım ancak bunların aynı sayfa içerisinde çalışması gerekmekte ikisi birlikte malesef çalışmıyor daha önce de böyle bir durumla hiç karşılaşmadım. Yardımcı olabilir misiniz...

Beraber çalıştırmak istediğim kodlar aşağıdaki gibidir;

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Cells(Target.Row, Target.Column + 4) = Date & " - " & Time
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim girilen As Byte
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("d1:d" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub

girilen = Target.Value
For i = 2 To girilen

Range("D" & Target.Row & "" & Target.Row + (girilen - 1)).Value = girilen
Next
End If
Application.EnableEvents = True
End Sub

Korhan Ayhan · 22 Eylül 2013

Aşağıdaki kodu deneyiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Target.Cells.Count > 1 Then Exit Sub
    Select Case Target.Column
        Case 1
            Target.Offset(0, 4) = Format(Now, "dd.mm.yyyy hh:mm:ss")
        Case 4
            Application.EnableEvents = False
            Range("D" & Target.Row & ":D" & Target.Row + Target - 1) = Target
    End Select
Son: Application.EnableEvents = True
End Sub

turist · 22 Eylül 2013

Korhan Ayhan' Alıntı:

Aşağıdaki kodu deneyiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Target.Cells.Count > 1 Then Exit Sub
    Select Case Target.Column
        Case 1
            Target.Offset(0, 4) = Format(Now, "dd.mm.yyyy hh:mm:ss")
        Case 4
            Application.EnableEvents = False
            Range("D" & Target.Row & ":D" & Target.Row + Target - 1) = Target
    End Select
Son: Application.EnableEvents = True
End Sub

Sayın Korhan Ayhan,
Aşağıdaki gibi iki koşulu tek kodla nasıl birleştirebiliriz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a5:a1000]) Is Nothing Then Exit Sub
Sheets("liste").Unprotect
Cells(Target.Row, Target.Column + 9) = Date
Sheets("liste").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
End Sub

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [k5:k1000]) Is Nothing Then Exit Sub
Cells(Target.Row, Target.Column + 1) = 1
End Sub

Korhan Ayhan · 22 Eylül 2013

Aşağıdaki gibi deneyiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [A5:A1000,K5:K1000]) Is Nothing Then Exit Sub
    Sheets("liste").Unprotect
        Select Case Target.Column
            Case 1
                Cells(Target.Row, Target.Column + 9) = Date
            Case 11
                Cells(Target.Row, Target.Column + 1) = 1
        End Select
Son: Sheets("liste").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End Sub

turist · 22 Eylül 2013

Sayın Korhan Ayhan,
Sağolunuz.

ebakirci · 14 Mart 2014

2 ayrı macro kodu aynı sayfa üzerinde çalıştırmam gerekiyor. kod:
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub

With Target
If .Value = "" Then Exit Sub
Cells(.Row, "I") = .Value + Cells(.Row, "I")
End With

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("f:f")) Is Nothing Then Exit Sub

With Target
If .Value = "" Then Exit Sub
Cells(.Row, "G") = .Value + Cells(.Row, "G")
End With

End Sub

yardımcı olursanız sevinirim...

Orion1 · 14 Mart 2014

onları silin.Alttakini yapıştırın.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("F:F,H:H")) Is Nothing Then Exit Sub

With Target
If .Value = "" Then Exit Sub
If .Column = 6 Then
    Cells(.Row, "G") = .Value + Cells(.Row, "G")
ElseIf .Column = 8 Then
    Cells(.Row, "I") = .Value + Cells(.Row, "I")
End If
End With
End Sub

ebakirci · 17 Mart 2014

2 ayrı macro kodu aynı sayfa üzerinde çalıştırma

Teşekkürler işe yaradı, emeğinize sağlık...

sinejan · 27 Mayıs 2016

2 ayrı macro kodu aynı sayfada çalıştırma

Merhaba, benimde 2 tane macro kodum var ve bunların aynı sayfa içerisinde çalışmasını istiyorum. Bu konu hakkında yardımlarınızı rica ediyorum.. Teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2:e500]) Is Nothing Then Exit Sub
If UCase(Target) <> Target Then
Target = Evaluate("=UPPER(" & Target.Address & ")")
End If
End Sub

diğeri;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub

kenkay · 24 Kasım 2016

tekrar engelleme ve saat ekleme

Merhaba benimde iki adet makrom var yardım edermisiniz

Kod:

 Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
    say = WorksheetFunction.CountIf(Range("a1:a" & Target.Row - 1), Target)
    If say > 0 Then
    MsgBox "BU KAYIT MEVCUTTUR"
    Target.Select
    Target = ""
    End If
    End Sub

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C1:C65536]) Is Nothing Then Cells(Target.Row, "A") = Format(Now, "hh:mm")
End Sub

ÖmerBey · 24 Kasım 2016

Merhaba,
Aşağıdaki şekilde deneyiniz.

Kod:

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [C1:C65536]) Is Nothing Then
        Application.EnableEvents = False
        Cells(Target.Row, "A") = Format(Now, "hh:mm")
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, [a:a]) Is Nothing Then
        On Error Resume Next
        say = WorksheetFunction.CountIf(Range("a1:a" & Target.Row - 1), Target)
        If say > 0 Then
            MsgBox "BU KAYIT MEVCUTTUR"
            Target.Select
            Target = ""
        End If
    End If
End Sub

kenkay · 24 Kasım 2016

mucit77' Alıntı:

Merhaba,
Aşağıdaki şekilde deneyiniz.

Kod:

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [C1:C65536]) Is Nothing Then
        Application.EnableEvents = False
        Cells(Target.Row, "A") = Format(Now, "hh:mm")
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, [a:a]) Is Nothing Then
        On Error Resume Next
        say = WorksheetFunction.CountIf(Range("a1:a" & Target.Row - 1), Target)
        If say > 0 Then
            MsgBox "BU KAYIT MEVCUTTUR"
            Target.Select
            Target = ""
        End If
    End If
End Sub

ne yaptıysam olmadı saat eklettiremiyorum tekrar çalışıyor ama saat çalışmıyor

turankr · 28 Aralık 2016

Arkadaşlar aşağıya yapıştırdığım kodlar çalışıyor ama çok kasıyor. İkisini birleştirip aynı işi kasmadan yapacak makro yazmak mümkün mü? Olursa çok sevinirim.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, [G:G]) Is Nothing Then GoTo 10
On Error GoTo son
ActiveSheet.Unprotect
Cells.Locked = False
If Target.Value = "MASRAF" Then
Range("I:I").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ÇIKAN" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "SATIŞ" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALC DEKONT" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "GİREN" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALIŞ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "BRÇ DEKONT" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "KASA DEVRİ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
son:
End If
10:
If Intersect(Target, [F:F]) Is Nothing Then GoTo 20
If Target <> "" And Target = Cells(Target.Row, "M") Then
Cells(Target.Row, "G") = "ÇIKAN"
End If
20:
If Intersect(Target, [M:M]) Is Nothing Then Exit Sub
If Target <> "" And Target = Cells(Target.Row, "F") Then
Cells(Target.Row, "G") = "ÇIKAN"
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 1 To Sheets("KASA").Range("F5000").End(3).Row ' i = 1 için KASA sayfası aralık F5000 e kadar olan satırları aşağı yöne tara
If (Cells(i, "F") = "") Then GoTo atla ' Eğer F boşsa atla
For F = 0 To Val(Cells(i, "AB").Value) ' Bu satırdaki F nin gösterdiği hedef satırı AB1 in değeri kadar satıra kopyala
s = s + 1 ' Her satıra yaz. Satır atlama, demek
For t = 1 To 13 ' 13 e kadar sütunlarda çalış demek
Sheets("RAPOR_2").Cells(s, t).Value = Sheets("KASA").Cells(i, t).Value 'Yukardaki şartlara uygunsa, KASA sayfasını RAPOR sayfasına eşitle
Next t
Next F
atla:
Next i
End Sub

Ömer BARAN · 28 Aralık 2016

turankr' Alıntı:
Arkadaşlar aşağıya yapıştırdığım kodlar çalışıyor ama çok kasıyor. İkisini birleştirip aynı işi kasmadan yapacak makro yazmak mümkün mü? Olursa çok sevinirim.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
...........
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
............
End Sub

Merhaba.

Sorunuzu, (az veri içerecek ve makrolar çalışır durumda olacak şekilde) örnek belgeyle destekleyiniz.
Belge içerisine veya buraya da amaçlanan işlemi açıklamanızda yarar var.

Böylece sonuca ulaşmanız ve alternatif cevaplar almanız da kolaylaşacaktır diye düşünüyorum.

Örnek belge özellikleri ve örnek belge ekleme yöntemine ilişkin açıklamalar cevabımın altındaki İMZA bölümünde var.

NOT: Forum sayfalarına ekleyeceğiniz kodları;
mesaj yazma alanının hemen üstünde # simgesine fareyle tıkladığınızda
göreceğiniz [ CODE ]...[ / CODE ] ayraçları arasına yapıştırarak eklemeniz daha doğru olur.
.

turankr · 30 Aralık 2016

Merhabalar,
-Yazıhaneden cevaplaya bildiğim için geciktim affola. Ayrıca ilgilenmiş olmanıza çok sevindim.
Dosyayı, tavsiye ettiğiniz ''dosya.tc'' adresine yükledim. Adres aşağıda.
-Ömer Hocam, dosyada KASA sayfasına bağlı çalışan iki makro var.
-Birincisi KASA sayfasında MASRAF, GİREN ve ÇIKAN kolonlarına duruma göre kilit yapıyor ve vade tarihi gelen ödemeler için ÇIKAN kolonuna 'ÇIKAN' yazdırıyor.
-İkincisi ise RAPOR_2 sayfasına veri aktarıyor.
-Problem, bu çalışmalar esnasında Excel'i çok kasması.
-Benim ricam ise, bu kodların aynı işi yapacak şekilde ama kasmadan çalışacak hale getirilmesi. Mümkün olursa minnettar kalırım.
-http://s3.dosya.tc/server10/ryf1e9/SEY_1_Ali__Mehmet__Halil_Yeni.rar.html

Ömer BARAN · 30 Aralık 2016

turankr' Alıntı:
........
-Birincisi KASA sayfasında MASRAF, GİREN ve ÇIKAN kolonlarına duruma göre kilit yapıyor ve vade tarihi gelen ödemeler için ÇIKAN kolonuna 'ÇIKAN' yazdırıyor.
-İkincisi ise RAPOR_2 sayfasına veri aktarıyor

Kodlarınız gereksiz uzun olmuş ve kullandığınız kısaltmaların da (for... değişkenleri) yapılan işlem ile bir ilgisi yok.

Bu nedenle işlemleri tam olarak anlamadım.

İsterseniz adım adım yapılacak işlemi açıklayın ve çözme konusuyla ilgileneyim.
Duruma göre gibi yuvarlak deyim yerine hangi durumda ne yapılacak onu belirtin.
.

turankr · 31 Aralık 2016

Yanlışlığı sonraki mesajda düzelttim.

turankr · 31 Aralık 2016

Ömer hocam,
1)

...............G........................H....................I....................J.......
------------------------------------------------------------------
1...........TİP...................MASRAF........GİREN..........ÇIKAN...
------------------------------------------------------------------
2.........ALIŞ ise................kilitlensin..............-..............kilitlensin..
------------------------------------------------------------------
3.........GİREN ise.............kilitlensin..............-..............kilitlensin..
------------------------------------------------------------------
4.........BRÇ DEKONT ise...kilitlensin...............-.............kilitlensin..
------------------------------------------------------------------
5.........KASA DEVRİ ise.....kilitlensin..............-...................-........
------------------------------------------------------------------
6.........SATIŞ ise..............kilitlensin.........kilitlensin............-.......
--------------------------------------------------.---------------
7.........ÇIKAN ise.............kilitlensin..........kilitlensin...........-.......
------------------------------------------------------------------
8.........MASRAF ise...............-................kilitlensin............-.......
------------------------------------------------------------------
9.........ALC DEKONT ise...kilitlensin..........kilitlensin............-.......
------------------------------------------------------------------

2)
F kolonundaki hücreler dolu ise ve vade tarihi bu güne eşitse G (TİP) kolonuna ÇIKAN yazsın.

3)
F kolonunun dolu olduğu satırları, 13 kolon boyunca RAPOR_2 sayfasına taşısın.
Kodlardaki yorum, çok anladığımdan değil. Anlamaya çalışırken aldığım notlar. Silmeden yollamışsam takılmayın.
Tablo düzeni bozulmasın diye boşlukları nokta ile doldurdum.

turankr · 31 Aralık 2016

Hocam pardon. Az veri ile ama derdimi anlattığım yeni bir dosya yükledim.
http://s3.dosya.tc/server10/i7wpwl/n_sekli_SIFRE_SORARSA-_1001378.02.01.2017.rar.html

turankr · 6 Ocak 2017

Ömer BARAN' Alıntı:
Merhaba.

Sorunuzu, (az veri içerecek ve makrolar çalışır durumda olacak şekilde) örnek belgeyle destekleyiniz.
Belge içerisine veya buraya da amaçlanan işlemi açıklamanızda yarar var.

Böylece sonuca ulaşmanız ve alternatif cevaplar almanız da kolaylaşacaktır diye düşünüyorum.

Örnek belge özellikleri ve örnek belge ekleme yöntemine ilişkin açıklamalar cevabımın altındaki İMZA bölümünde var.

NOT: Forum sayfalarına ekleyeceğiniz kodları;
mesaj yazma alanının hemen üstünde # simgesine fareyle tıkladığınızda
göreceğiniz [ CODE ]...[ / CODE ] ayraçları arasına yapıştırarak eklemeniz daha doğru olur.
.

Ömer hocam dediğinizi yaptım. Dosyaya bakabildiniz mi?

2 ayrı macro kodu aynı sayfa üzerinde çalıştırma ?

aykut12344

Korhan Ayhan

Administrator

turist

Destek Ekibi

Korhan Ayhan

Administrator

turist

Destek Ekibi

ebakirci

Orion1

Uzman

ebakirci

sinejan

kenkay

ÖmerBey

Destek Ekibi

kenkay

turankr

Ömer BARAN

Uzman

turankr

Ömer BARAN

Uzman

turankr

turankr

turankr

turankr