tebrikler elinize sağlık çok güzel olmuş benzeri birşey hazırlamak istiyorum vb kısmının parolasını verme imkanıınz varı tamamen inceleme amaclı tesekkurler
Şifreyi veremem amam kodları paylaşıyorum, buyurun,
Sub BulmacaHazirla()
ActiveSheet.PageSetup.RightFo
oter = "Hazırlayan: Yunus KÜLCÜ"
ActiveSheet.PageSetup.LeftFoo
ter = "
[linkler sadece üyelerimize görünmektedir.] "
'hızlansın diye eklendi
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
'hızlansın diye eklendi
buyuksayac = 1
enbas:
buyuksayac = buyuksayac + 1
If buyuksayac > 10000 Then MsgBox "Başaramadık
": GoTo enson
'temizlik
Range("a2:p25") = ""
Dim Sh As Shape
With ActiveSheet
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("a2:p25")) Is Nothing Then Sh.Delete
Next Sh
End With
On Error Resume Next
sorusayisi = Range("ae1")
sorulacakss = Range("ae2")
ReDim sorular(sorusayisi)
ReDim cevaplar(sorusayisi)
ReDim soruisaret(sorusayisi)
ReDim yazilansorular(sorulacakss)
ReDim yazilancevaplar(sorulacakss)
For a = 1 To sorusayisi
sorular(a) = Cells(a + 3, 18)
cevaplar(a) = Cells(a + 3, 29)
Next a
k = karisiksayi(kar, Int(sorulacakss), 1, Int(sorusayisi))
For b = 1 To sorulacakss
sayalim = 1
yeniden:
Randomize
yataydikey = Int(Rnd() * 2 + 1)
digerinabak: 'yatay bakı dikeye baksın veya tersi
soruisaret(kar(b)) = 1
sayalim = sayalim + 1
If sayalim > 3 Then GoTo enbas
If yataydikey = 1 Then 'dikey
kelime = cevaplar(kar(b))
kelimeuzunluk = Len(kelime)
If kelimeuzunluk >= 10 Then GoTo yeniden
ymin = 3
ymax = 13 - kelimeuzunluk
xmin = 3
xmax = 14
'''''''''''''''''''''''''11111111111111111111111111111
1111111111111111111111111
If b = 1 Then
yeniden1:
x = aradasayi(xmax, xmin)
y = aradasayi(ymax, ymin)
If Cells(y - 1, x) <> "" Then GoTo yeniden1
f = "+"
k = 1
For a = 1 To kelimeuzunluk
If Cells(y + a - 1, x) <> "" And Cells(y + a - 1, x) <> Mid(kelime, a, 1) Then f = "-"
If Cells(y + a - 1, x) <> "" Then k = k + 1
Next a
If Cells(y + a - 1, x) <> "" Then GoTo yeniden1
If b > 1 And k = 1 Then GoTo yeniden1
If f = "-" Then GoTo yeniden1
For a = 1 To kelimeuzunluk
Cells(y + a - 1, x) = Mid(kelime, a, 1)
Next a
Cells(y + a - 1, x) = "."
Cells(y - 1, x) = b
ActiveSheet.DrawingObjects("okasagi").Select
Selection.Copy
Cells(y - 1, x).Select
ActiveSheet.Paste
End If
'''''''''''''''''''''''''11111111111111111111111111111
1111111111111111111
If b > 1 Then
yazil = "-"
For xde = xmin To xmax
For yde = ymin To ymax
x = xde
y = yde
If Cells(y - 1, x) <> "" Then GoTo yeniden2
f = "+"
k = 1
For a = 1 To kelimeuzunluk
If Cells(y + a - 1, x) <> "" And Cells(y + a - 1, x) <> Mid(kelime, a, 1) Then f = "-"
If Cells(y + a - 1, x) <> "" Then k = k + 1
Next a
If Cells(y + a - 1, x) <> "" Then GoTo yeniden2
If b > 1 And k = 1 Then GoTo yeniden2
If f = "-" Then GoTo yeniden2
For a = 1 To kelimeuzunluk
Cells(y + a - 1, x) = Mid(kelime, a, 1)
Next a
Cells(y + a - 1, x) = "."
Cells(y - 1, x) = b
ActiveSheet.DrawingObjects("okasagi").Select
Selection.Copy
Cells(y - 1, x).Select
ActiveSheet.Paste
yazil = "+"
GoTo yazdikatla1
yeniden2:
If yde = ymax And xde = xmax And yazil = "-" Then yataydikey = 2: GoTo digerinabak
Next yde
Next xde
End If
End If
yazdikatla1:
If yataydikey = 2 Then 'yatay
kelime = cevaplar(kar(b))
kelimeuzunluk = Len(kelime)
If kelimeuzunluk >= 12 Then GoTo yeniden
xmin = 3
xmax = 15 - kelimeuzunluk
ymin = 3
ymax = 12
''''''''''''''''''''''22222222222222222222222222222
222222222222222222222222
If b = 1 Then
yeniden3:
x = aradasayi(xmax, xmin)
y = aradasayi(ymax, ymin)
If Cells(y, x - 1) <> "" Then GoTo yeniden3
k = 1
f = "+"
For a = 1 To kelimeuzunluk
If Cells(y, x + a - 1) <> "" And Cells(y, x + a - 1) <> Mid(kelime, a, 1) Then f = "-"
If Cells(y, x + a - 1) <> "" Then k = k + 1
Next a
If Cells(y, x + a - 1) <> "" Then GoTo yeniden3
If b > 1 And k = 1 Then GoTo yeniden3
If f = "-" Then GoTo yeniden3
For a = 1 To kelimeuzunluk
Cells(y, x + a - 1) = Mid(kelime, a, 1)
Next a
Cells(y, x + a - 1) = "."
Cells(y, x - 1) = b
ActiveSheet.DrawingObjects("oksaga").Select
Selection.Copy
Cells(y, x - 1).Select
ActiveSheet.Paste
End If
If b > 1 Then
yazil = "-"
For xde = xmin To xmax
For yde = ymin To ymax
x = xde
y = yde
If Cells(y, x - 1) <> "" Then GoTo yeniden4
k = 1
f = "+"
For a = 1 To kelimeuzunluk
If Cells(y, x + a - 1) <> "" And Cells(y, x + a - 1) <> Mid(kelime, a, 1) Then f = "-"
If Cells(y, x + a - 1) <> "" Then k = k + 1
Next a
If Cells(y, x + a - 1) <> "" Then GoTo yeniden4
If b > 1 And k = 1 Then GoTo yeniden4
If f = "-" Then GoTo yeniden4
For a = 1 To kelimeuzunluk
Cells(y, x + a - 1) = Mid(kelime, a, 1)
Next a
Cells(y, x + a - 1) = "."
Cells(y, x - 1) = b
ActiveSheet.DrawingObjects("oksaga").Select
Selection.Copy
Cells(y, x - 1).Select
ActiveSheet.Paste
yazil = "+"
GoTo yazdikatla2
yeniden4:
If yde = ymax And xde = xmax And yazil = "-" Then yataydikey = 1: GoTo digerinabak
Next yde
Next xde
End If
End If
yazdikatla2:
Cells(15, 1) = Cells(15, 1) & Chr(10) & b & ")" & sorular(kar(b))
Next b
'bitti noktaları kaldıralım
For a = 2 To 13
For b = 2 To 15
If Cells(a, b) = "." Then Cells(a, b) = ""
Next b
Next a
'yazılara boşluk koyalım
For a = 2 To 13
For b = 2 To 15
ne = ""
If Cells(a, b) >= 1 And Cells(a, b) < 1000 And Cells(a, b) <> "" Then ne = "sayi"
If Cells(a, b) <> "" And ne = "" Then Cells(a, b) = " "
Next b
Next a
enson:
'hızlansın diye eklendi
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'hızlansın diye eklendi
End Sub
Bunlar da fonksiyonlar, hangileri kullanılıyor hatırlamıyorum, kullanılmayanlar olabilir
Function benzermi(diziadi As Variant, DiziTumElemanSayisi As Integer) As String
For a = 1 To DiziTumElemanSayisi
'don3:
'Randomize
'harfrakam(a) = Int(Rnd() * 10 + 1)
For b = 1 To DiziTumElemanSayisi
If a <> b And diziadi(a) = diziadi(b) And diziadi(a) <> "" Then
benzermi = "benzer"
GoTo 10
Else
benzermi = "benzer değil"
End If
Next b
Next a
10
End Function
Function karisiksayi(diziadi As Variant, kacsayi As Integer, altdeger As Integer, ustdeger As Integer)
ReDim diziadi(kacsayi)
For a = 1 To kacsayi
tekrar:
Randomize
diziadi(a) = Int(Rnd() * (ustdeger - altdeger + 1) + altdeger)
For b = 1 To kacsayi
If a <> b And diziadi(a) = diziadi(b) And diziadi(a) <> "" Then GoTo tekrar
Next b
Next a
End Function
Function yazilirmiy(konumx, konumy, kelime)
esitmi = "+"
x = konumx
y = konumy
uzunluk = Len(kelime)
say = 1
For a = 1 To uzunluk
If Cells(y, x + a - 1) <> "" And Cells(y, x + a - 1) <> Mid(kelime, a, 1) Then
esitmi = "-"
End If
If Cells(y, x + a - 1) <> "" Then say = say + 1
Next a
If say = 1 Then esitmi = "-"
yazilirmiy = esitmi
End Function
Function yazilirmid(konumx, konumy, kelime)
esitmi = "+"
x = konumx
y = konumy
uzunluk = Len(kelime)
say = 1
For a = 1 To uzunluk
If Cells(y + a - 1, x) <> "" And Cells(y + a - 1, x) <> Mid(kelime, a, 1) Then
esitmi = "-"
End If
If Cells(y + a - 1, x) <> "" Then say = say + 1
Next a
If say = 1 Then esitmi = "-"
yazilirmid = esitmi
End Function
Function aradasayi(buyuk, kucuk)
Randomize
aradasayi = Int(Rnd() * (buyuk - kucuk + 1) + kucuk)
End Function