• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücreye çift tıklayınca 1 artırma

Katılım
25 Aralık 2004
Mesajlar
1,793
Excel Vers. ve Dili
Office 2016 Pro Plus-Türkçe
Selamlar.
Kod arşiv programında işime yarayacak bir kod var. Hücreye çift tıklayınca değeri 1 artırıyor.
Ancak sadece 2. sütun için bunu yapıyor. Bu kodu, D3;AG32 arasını kapsayacak şekilde nasıl değiştiriyoruz?
Kod:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target _
       As Range, Cancel As Boolean)
  Cancel = True   'Get out of edit mode
  If Target.Row = 1 Then Exit Sub
  [color=red]If Target.Column <> 2 Then Exit Sub  'Require Col B[/color]
  On Error Resume Next
  Application.EnableEvents = False
  Target.Value = Target.Value + 1
  Application.EnableEvents = True
  If Err.Number <> 0 Then
     MsgBox "Unable to add 1 to value in cell " _
       & Target.Address(0, 0)
  End If
End Sub
 
yanıt

Kod:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target _
       As Range, Cancel As Boolean)
  Cancel = True   'Get out of edit mode
  If Target.Row = 1 Then Exit Sub
  [COLOR="Blue"]If Intersect(Target, [D3:AG32]) Is Nothing Then Exit Sub[/COLOR]
  On Error Resume Next
  Application.EnableEvents = False
  Target.Value = Target.Value + 1
  Application.EnableEvents = True
  If Err.Number <> 0 Then
     MsgBox "Unable to add 1 to value in cell " _
       & Target.Address(0, 0)
  End If
End Sub
 
Buldum :)
Kod:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target _
       As Range, Cancel As Boolean)
  Cancel = True   'Get out of edit mode
If Intersect(Target, Range("D3:AG32")) Is Nothing Then Exit Sub
  On Error Resume Next
  Application.EnableEvents = False
  Target.Value = Target.Value + 1
  Application.EnableEvents = True
  If Err.Number <> 0 Then
     MsgBox "Unable to add 1 to value in cell " _
       & Target.Address(0, 0)
  End If
End Sub
 
Çok teşekkür ederim Sn.Hiçdurmaz.
Gerçi çözüme ben de ulaştım ama ilginiz için tekrar teşekkürler.
 
Geri
Üst