Tombala da üst sınırı 800 yapmak istiyorum

[tahsinanarat]

Mükerrer oldu, dosyam 2.mesajımda

 

[tahsinanarat]

Tombala dosyasındaki sayının 800 e kadar çıkartılması

Kodlar Necdet Yeşerneter hocama ait olup, ben bunları üç rakamlı olarak yani 90 değilde 800'e kadar olan rakamları aynı mantıkla çalıştırmak istiyorum.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo Son
If Intersect(Target, [B2:K10]) Is Nothing Then Exit Sub
If Target.Font.ColorIndex = 2 Then Exit Sub
[M2] = Target.Value
Son:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [M2]) Is Nothing Then Exit Sub
Select Case Len([M2])
Case 1
Sat = 2
sut = [M2] + 1
Case 2
Sat = Left([M2], 1) + 2
sut = Right([M2], 1) + 1
If sut = 1 Then
sut = 11
Sat = Sat - 1
End If
End Select

Cells(Sat, sut).Interior.ColorIndex = 2
Cells(Sat, sut).Font.ColorIndex = 2
Sonsat = [M65536].End(3).Row + 1
Cells(Sonsat, "M") = Target
Cells(Sonsat, "N") = Time
Target.Offset(0, 0).Select
Son:
End Sub

 

[tahsinanarat]

Sanıyorum yukarıda sorunumu pek izah edemedim, yukarıda verdiğim tombala çekelişi dosyasında birden 99 a kadar olan sayıların üzerinde çift tıklandığında tıklanan sayı m sutununa, tıklandığı saat ise n sutununa yazılarak tıklanan hücre silinerek beyaz olmaktadır. Ben bu işlemlerin diğer sayılar içinde yani 800'e kadar olan sayılar içinde aynı işlemin olmasını istiyorum, bunun için kodda nasıl bir değişikliğe gitmeliyim, ne yaptımsa olmadı. Yardımcı olabilecek hocalarıma şimdiden teşekkürlerimi sunuyorum.

 

[Korhan Ayhan]

Merhaba,

Kodun içindeki aşağıdaki satırı;

Case 2

Aşağıdaki gibi düzenleyip deneyiniz.

Case 2, 3

 

[tahsinanarat]

Sn. Korhan hocam ilginiz için çok teşekkür ediyorum, dediğiniz şekilde yaptığım değişiklik sonucunda m ve n sutununa yazma işlemini yapıyor ancak zemin rengini değiştirmiyor, bu konuda da yardımcı olabilirseniz sevinirim.

 

[tahsinanarat]

Sn. hocalarım, yardımlarınızı bekliyorum.

 

[tahsinanarat]

Şu şekilde bir çözüm buldum, umarım doğru yapmışımdır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Static EskiHucre As Range
On Error GoTo Son
If Intersect(Target, [B2:K81]) Is Nothing Then Exit Sub
If Target.Font.ColorIndex = 2 Then Exit Sub
[M2] = Target.Value
On Error Resume Next
If Target.Interior.ColorIndex = 15 Then
Target.Interior.ColorIndex = 2
EskiHucre.Interior.ColorIndex = xlColorIndexNone
Set EskiHucre = Target
Else
EskiHucre.Interior.ColorIndex = xlColorIndexNone
End If
Son:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [M2]) Is Nothing Then Exit Sub
Select Case Len([M2])
    Case 1
        Sat = 2
        sut = [M2] + 1
    Case 2, 3
        Sat = Left([M2], 1) + 2
        sut = Right([M2], 1) + 1
        If sut = 1 Then
            sut = 11
            Sat = Sat - 1
        End If
 End Select
    
Sonsat = [M65536].End(3).Row + 1
Cells(Sonsat, "M") = Target
Cells(Sonsat, "N") = Now
Target.Offset(0, 0).Select
Son:
End Sub

 

[Korhan Ayhan]

Merhaba,

Sadece aşağıdaki kod yeterli olacaktır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error GoTo Son
    If Intersect(Target, Range("B2:K81")) Is Nothing Then Exit Sub
    If Target.Font.ColorIndex = 2 Then Exit Sub
    Cancel = True
    Range("M2") = Target.Value
    Target.Interior.ColorIndex = 2
    Target.Font.ColorIndex = 2
    Satir = Cells(Rows.Count, "M").End(3).Row + 1
    Cells(Satir, "M") = Target
    Cells(Satir, "N") = Now
Son:
End Sub

 

[tahsinanarat]

Sn. Korhan hocam son noktayı koydunuz yine, kısa ve öz, ilginize çok teşekkür ediyorum. Elinize sağlık.