otomatik çalışan makroyu durdurma

[spacebar]

merhaba üstadlarım. sayfamda otomatik çalışan bir makrom var. aktif hücredeyken yazıyı büyüten bir makro çalışıyor. bu makroyu butonla durdurabilirmiyiz.
teşekkürler. sağlıklı günler dilerim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim xRg As Range
    Dim xCell As Range
    Dim xShape As Variant
    Set xRg = Target.Areas(1)
    For Each xShape In ActiveSheet.Pictures
        If xShape.Name = "BUYUT" Then
            xShape.Delete
        End If
    Next
    If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then Exit Sub
    Application.ScreenUpdating = False
    xRg.CopyPicture appearance:=xlScreen, Format:=xlPicture
    Application.ActiveSheet.Pictures.Paste.Select
    With Selection
        .Name = "BUYUT"
        With .ShapeRange
            .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
            With .Fill
                .ForeColor.SchemeColor = 44
                .Visible = msoTrue
                .Solid
                .Transparency = 0
            End With
        End With
    End With
    xRg.Select
    Application.ScreenUpdating = True
    Set xRg = Nothing
End Sub

 

[Korhan Ayhan]

Merhaba,

Boş bir modülde en üst satıra aşağıdaki ifadeyi yazınız.

Butona kodu atadıktan sonra ilk tıkladığınızda macronuz devredışı kalacaktır. İkinci kez tıkladığınızda tekrar devreye girecektir.

Option Explicit
Public Kontrol As Boolean

Sub My_Macro_Stop_Or_Run()
    Kontrol = Not Kontrol
End Sub

Sonra kullandığınız kodu aşağıdaki gibi değiştiriniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Kontrol = True Then Exit Sub
  
    Dim xRg As Range
    Dim xCell As Range
    Dim xShape As Variant
    Set xRg = Target.Areas(1)
    For Each xShape In ActiveSheet.Pictures
        If xShape.Name = "BUYUT" Then
            xShape.Delete
        End If
    Next
    If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then Exit Sub
    Application.ScreenUpdating = False
    xRg.CopyPicture appearance:=xlScreen, Format:=xlPicture
    Application.ActiveSheet.Pictures.Paste.Select
    With Selection
        .Name = "BUYUT"
        With .ShapeRange
            .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
            With .Fill
                .ForeColor.SchemeColor = 44
                .Visible = msoTrue
                .Solid
                .Transparency = 0
            End With
        End With
    End With
    xRg.Select
    Application.ScreenUpdating = True
    Set xRg = Nothing
End Sub

 

[spacebar]

Üstad ellerinize sağlık. mükemmel çalışıyor. teşekkür eder sağlıklı günler dilerim.

 

[spacebar]

@Korhan Ayhan üstadım merhaba. öğrenmek için soruyorum. bir buton ekledim üzerine "Büyütmeyi Kapat" diye yazdım. Butona bastığımda makro duruyor. yani yazdığınız makro sorunsuz çalışıyor ama bu anda buton üzerindeki yazıyı makro ile "Büyütmeyi Aç" olarak değiştirilebilir mi. veya buton üzerindeki yazı metni bir hücreden alınabilir mi. teşekkürler...

 

[Korhan Ayhan]

Butonu nerden eklemiştiniz?

 

[spacebar]

form denetiminden ekledim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit
Public Kontrol As Boolean

Sub My_Macro_Stop_Or_Run()
    Kontrol = Not Kontrol
    
    If ActiveSheet.Buttons(Application.Caller).Caption = "Büyütmeyi Kapat" Then
        ActiveSheet.Buttons(Application.Caller).Caption = "Büyütmeyi Aç"
    Else
        ActiveSheet.Buttons(Application.Caller).Caption = "Büyütmeyi Kapat"
    End If
End Sub

 

[spacebar]

Korhan Bey olabileceğine çok fazla ihtimal vermiyordum. ellerinize sağlık. çok teşekkür ederim.

 

[spacebar]

@Korhan Ayhan üstadım küçük bir sorun var. şimdi fark ettim. belgeyi açarken butonda "Büyütmeyi Aç" yazıyor ise buton üzerindeki yazı ile makro çalışması ters oluyor. belge kapatıldığında veya açıldığında buton üzerinde "Büyütmeyi Kapat" yazması gerekiyor. ben sizin kodlara göre çok deneme yaptım ama başaramadım.

 

[uzmanamele]

Public BigSmall As Byte


Private Sub ToggleButton1_Click()
If ToggleButton1 = True Then
ToggleButton1.Caption = "Büyük"
BigSmall = 1
Else
ToggleButton1.Caption = "Küçük"
BigSmall = 0
End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If BigSmall = 0 Then Exit Sub

Dim xRg As Range
Dim xCell As Range
Dim xShape As Variant
Set xRg = Target.Areas(1)
For Each xShape In ActiveSheet.Pictures
If xShape.Name = "BUYUT" Then
xShape.Delete
End If
Next
If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then Exit Sub
Application.ScreenUpdating = False
xRg.CopyPicture appearance:=xlScreen, Format:=xlPicture
Application.ActiveSheet.Pictures.Paste.Select
With Selection
.Name = "BUYUT"
With .ShapeRange
.ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
With .Fill
.ForeColor.SchemeColor = 44
.Visible = msoTrue
.Solid
.Transparency = 0
End With
End With
End With
xRg.Select
Application.ScreenUpdating = True
Set xRg = Nothing
End Sub

 

[spacebar]

uzmanamele üstadım olmadı. makroyu çalıştıramadım. aslında sadece açılışta veya kapanışta "Büyütmeyi Kapat" yazması benim için yeterli. ilginize teşekkür ederim.

 

[Korhan Ayhan]

Dosyanızın ThisWorkbook (BuÇalışmaKitabı) bölümüne uygulayınız.

Bold bölümleri kendi dosyanıza göre uyarlamalısınız.

Option Explicit

Private Sub Workbook_Open()
Sheets("Sheet1").Buttons("Button 1").Caption = "Büyütmeyi Kapat"
End Sub

 

[spacebar]

üstad harika oldu. internette butona isim atama hakkında hiç bir örnek yoktu. isterseniz bulunması açısından ayrı başlık açayım. teşekkür ederim ellerinize sağlık.

 

[Korhan Ayhan]

Arayan bulur merak etmeyin..