Sudoku

muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Arkadaşlar, sayın hocalarım, kodlarını biraz internetten bulup, biraz eklenti yaptığım ve hocalarıma danışarak, özellikle @Muzaffer Ali hocamın çok başını ağrıttım. Teşekkür ederim. Sonunda Sudoku bitti. Paylaşmak istedim.
Saygılarımla.
 

Ekli dosyalar

muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali' Alıntı:
Bazı eklemeler yaptım. Biraz daha iyi oldu gibi.

Sudoku_Yeni.xlsm dosyasını indir - download

Sudoku_Yeni.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
Genişletmek için tıkla ...
Hocam emeğinize sağlık. Hem çok güzel bir görsel hem de kalan rakam yazması çok güzel olmuş. Biraz da yaratıcılık. O da ben de yok :) Ben sadece gazeteden çözdüğüm için.
Hocam, biliyorum yeter artık diyeceksiniz ama uğraştım yapamadım. Bu "kaç rakam koyacağına" açılışta bir InputBox ile "zorluk derecesi 1 ile 10 arası değer giriniz" sorsa. O şekil bir şey eklenebilir mi?
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,354
Excel Vers. ve Dili
2019 Türkçe
Elbette yapılabilir fakat InputBox dan dönen rakam kodların neresinde kullanılacağını da söylersen ona göre kod yazayım.
 
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali' Alıntı:
Elbette yapılabilir fakat InputBox dan dönen rakam kodların neresinde kullanılacağını da söylersen ona göre kod yazayım.
Genişletmek için tıkla ...
Hocam örneğin şu an 81 kare içerisine 25 rakam serpiştiriyor. Bu aslında çok kolay bir bulmaca oluyor.
InputBox ile "Zorluk derecesi 1 ile 10 arasında değer belirtin" diyecek. (Hatta harf, sembol ya da 1-10 harici bir şey yazınca uyarı verebilir)
InputBox'a
1 yazarsak 25 sayı serpiştirecek
2 yazarsak 22 sayı serpiştirecek
3 yazarsak 20 sayı serpiştirecek
4 yazarsak 18 sayı serpiştirecek
5 yazarsak 16 sayı serpiştirecek
6 yazarsak 15 sayı serpiştirecek
7 yazarsak 13 sayı serpiştirecek
8 yazarsak 12 sayı serpiştirecek
9 yazarsak 11 sayı serpiştirecek
10 yazarsak 10 sayı serpiştirecek
Sayılar koddan değiştirilebilir sanırım.
Böyle bir şey hocam.
İlginize teşekkür ederim.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
386
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
muratgunay48' Alıntı:
Emeğinize sağlık hocam. Yalnız benim yapmaya uğraştığım çözmek için değil oluşturmak için. :)
Uğraşıp kendimiz çözeceğiz. Muzaffer Ali hocam kontrol kısmını yazdı. Çözüm değil.
Ayrıca haddimi aşıyorsam özür dilerim. İmzadaki sözün GIORDANO BRUNO'ya ait olması mantıksız olur. Çünkü müslüman değildi. Müslüman olmayan kimse ALLAH demez. Tanrı der, Yehova der, Şiva der, Zeus der.........
Saygılarımla.
Genişletmek için tıkla ...
@muratgunay48
İlk önce altın üyeliğim bittiği için yüklenilen dosyayı göremedim ve konuyu da yanlış anlamışım bu nedenle sudoku çözümünün kodunu cevap olarak yazdım. O zaman yazdığım kodu siliyorum.
Ayrıca tabi ki sudoku çözmesini çok severim ve de bazen kafa dağıtmak için de çözerim.

İmzamda geçen söz İtalyan Felsefeci GIORDANO BRUNO ya ait olup kelimenin orjinali "Tanrı" dır. Benim inancıma göre Allah ile Tanrı kelimesinin farklı anlamlar taşıması nedeniyle Tanrı kelimesini Allah ile değiştirerek imzamı oluşturdum.

Saygılarımla.

NOT. Ben yazmış olduğum cevabı sildim. Lütfen siz de Alıntılıyarak bana hitaben yazdığınız cevaptaki kodu siler misiniz.
 
Son düzenleme:
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,354
Excel Vers. ve Dili
2019 Türkçe
Aslında anlık kontrol eklemek lazım. Boş bir vaktimde bakarım ona da.
Not ekleme falan da olmalı bence.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
386
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

1- Hücre renkleri beyaz oluyor.
2- Otomatik verilen rakamların font rengi mavi oluyor. (Bence otomatik verilen sayılar bilinmeli)


Kod: 
Sub CreatePuzzle(Zorluk As Variant)

    Dim CellRow As Integer, CellCol As Integer
    Dim num As Integer, LoopCount As Integer
    Dim uCell As Integer, Comp As Boolean
    Dim myRng As Range
   
    Set myRng = Range("A2:J10")
   
    myRng.Font.ColorIndex = xlAutomatic
   
    Sheets("Sudoku").Range("B2:J10").Copy Sheets("Solution").Range("B2")
   
    LoopCount = 0
    Do
        Randomize
        CellRow = Int((10 - 2 + 1) * Rnd + 2)
        CellCol = Int((10 - 2 + 1) * Rnd + 2)
        Cells(CellRow, CellCol).Value = ""
        Cells(CellRow, CellCol).Font.Bold = False
        If Zorluk = 1 Then Zorluk = 0
        If WorksheetFunction.CountIf(Range("B2:J10"), "<>") = 40 - (Zorluk * 2) Then Exit Do
    Loop
    Sheets("Solution").Range("B2:J10").Font.Color = vbBlack
    myRng.Interior.Color = ColorConstants.vbWhite
    myRng.SpecialCells(xlCellTypeConstants).Font.ColorIndex = 32
   
    Set myRng = Nothing
   
End Sub
 
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
dost' Alıntı:
Merhaba,

1- Hücre renkleri beyaz oluyor.
2- Otomatik verilen rakamların font rengi mavi oluyor. (Bence otomatik verilen sayılar bilinmeli)


Kod: 
Sub CreatePuzzle(Zorluk As Variant)

    Dim CellRow As Integer, CellCol As Integer
    Dim num As Integer, LoopCount As Integer
    Dim uCell As Integer, Comp As Boolean
    Dim myRng As Range
  
    Set myRng = Range("A2:J10")
  
    myRng.Font.ColorIndex = xlAutomatic
  
    Sheets("Sudoku").Range("B2:J10").Copy Sheets("Solution").Range("B2")
  
    LoopCount = 0
    Do
        Randomize
        CellRow = Int((10 - 2 + 1) * Rnd + 2)
        CellCol = Int((10 - 2 + 1) * Rnd + 2)
        Cells(CellRow, CellCol).Value = ""
        Cells(CellRow, CellCol).Font.Bold = False
        If Zorluk = 1 Then Zorluk = 0
        If WorksheetFunction.CountIf(Range("B2:J10"), "<>") = 40 - (Zorluk * 2) Then Exit Do
    Loop
    Sheets("Solution").Range("B2:J10").Font.Color = vbBlack
    myRng.Interior.Color = ColorConstants.vbWhite
    myRng.SpecialCells(xlCellTypeConstants).Font.ColorIndex = 32
  
    Set myRng = Nothing
  
End Sub
Genişletmek için tıkla ...
Güzel bir çalışma olmuş hocam. Emeğinize sağlık.
Hatta renk değiştirilebilir olmuş.
Teşekkürler.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,354
Excel Vers. ve Dili
2019 Türkçe
Son hali bu şekilde.
Otomatik eklenen rakamlar kalın olacak şekilde ayarladım.
Hata kontrolünü yazarken yapıyor.
Biraz daha görünüm özelliği ekledim.

Sudoku_Yeni__3_.xlsm dosyasını indir - download

Sudoku_Yeni__3_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
 

Ekli dosyalar

Son düzenleme:
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali' Alıntı:
Son hali bu şekilde.
Otomatik eklenen rakamlar kalın olacak şekilde ayarladım.
Hata kontrolünü yazarken yapıyor.
Biraz daha görünüm özelliği ekledim.

Sudoku_Yeni__3_.xlsm dosyasını indir - download

Sudoku_Yeni__3_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
Genişletmek için tıkla ...
Hocam emeğinize sağlık, artık bu sizin sayenizde benim Hintli gençten bulup biraz eklemeler yaptığım basit sudokudan çok öteye evrildi.
Yalnız hocam 2 husus var. Birincisi yanlış yazar yazmaz kırmızı olması Sudoku mantığına aykırı. Bence onu kaldıralım. Kontrol koyalım tekrar.
İkincisi Küçük Ekran çok güzel olmuş, emeğinize sağlık. Yalnız açılışta sağdan soldan ortalı olsa, üzerinize afiyet bende simetri var da 😔 cidden kötü bir şey. Hiçbir hastalık tarif edilmez de. Belki size saçma gelecek.
Mesela butonları da hemen eşitledim.
Ama sudokuyu ortalayamadım.
Tekrar teşekkür ederim.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,354
Excel Vers. ve Dili
2019 Türkçe
Geçmiş olsun. Allah şifa versin.
Belki yazarken kontrol meselesi seçenek olarak sunulsa daha iyi olur.
Ekran konumu da manuel yapılsa daha iyi olur. Windows taşıma kısmı görünür olsun isteyen istediği yere taşısın.
Müsait olunca bakacağım.
 
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali' Alıntı:
Geçmiş olsun. Allah şifa versin.
Belki yazarken kontrol meselesi seçenek olarak sunulsa daha iyi olur.
Ekran konumu da manuel yapılsa daha iyi olur. Windows taşıma kısmı görünür olsun isteyen istediği yere taşısın.
Müsait olunca bakacağım.
Genişletmek için tıkla ...
Çok teşekkür ederim hocam. İyi dilekleriniz çok anlamlı.
 
muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,305
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Altın Üyelik Bitiş Tarihi
31-01-2026
Muzaffer Ali' Alıntı:
Geçmiş olsun. Allah şifa versin.
Belki yazarken kontrol meselesi seçenek olarak sunulsa daha iyi olur.
Ekran konumu da manuel yapılsa daha iyi olur. Windows taşıma kısmı görünür olsun isteyen istediği yere taşısın.
Müsait olunca bakacağım.
Genişletmek için tıkla ...
Hocam, şekil kısmını haddim olmayarak düzelttim. :)
Sizden ricam. Kontrol kısmını eski şekline getirsek. Yazınca kırmızı olmasın lütfen.
Bir de hocam, yeni oyun deyince zorluk soruyor sizin yazdığınız kodda. İlk açtığımızda neden sormuyor. O da neticede yeni oyun olacak.
Bir de oyun zorlukta CANCEL tıklayınca gitmiyor. Mutlaka seçtirecek. Vazgeçtim oynamayacağım. :)
Sonra bitti. Sayenizde elbette. Benim ilk sudoku dosyasıyla bunun alakası yok. Tek benzerliği 81 rakam var :)
Saygılarımla.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst