Kelime Bulmaca

[iskelet]

Selamlar,
Yapmak istediğim şeyde ekli dosyada belirtilmiştir.
Şimdiden ilgilenecek arkadaşlara teşekkürler.

 

[iskelet]

selamlar
İnceleyen arkadaşlar yorum yaparsa sevinirim olup olmayacağı ile ilgili.

 

[muygun]

Merhaba;
Dosya içinde açıkladığınız metni soru olarak buraya yazarsan eminim çözüm bulacaksınız (en azından bir çözüm benden)
Ama zahmet edip lütfen soru açıklamasını buraya yazın.
İyi çalışmalar.

 

[iskelet]

Merhaba;
Dosya içinde açıkladığınız metni soru olarak buraya yazarsan eminim çözüm bulacaksınız (en azından bir çözüm benden)
Ama zahmet edip lütfen soru açıklamasını buraya yazın.
İyi çalışmalar.

Sayın muygun uyarınız için teşekkürler.

Yapmak istediğim şey A sütunundaki kelimleri B1-M14 alanına soldan-sağa veya yukarıdan-aşağıya doğru rastgele yerleştirmesini ve boş kalan hücrelerede 29 harften rastgele yerleştirmesini istiyorum. Kısacası bulmaca oluşturmak istiyorum.
İnşallah anlatabilmişimdir.
Şimdiden teşekkürler.

 

[muygun]

Merhaba;
Eki inceleyin.
İyi çalışmalar.

 

[iskelet]

Sayın muygun ilk önce ilginiz için teşekkürler.
Ama herhalde ben yanlış anlattım.
Siz kelimeleri bir bütün olarak hücreye yerleştirmişsiniz.
Benim demek istediğim mesala YUSUF kelimesini örnek alalım
YUSUF kelimesini yerleştirirken F1 Y F2 U F3 S F4 U F5 F olacak şekilde yerleştirmesi idi.
Diğer kelimeleride aynı şekilde soldan-sağa veya yukarıdan - aşağıya şekilde yerleştirmesi.
Yani Kelime Avı bulmacası hazırlamak istiyorum.

 

[Ömer]

Merhaba,

Linki inceleyiniz.

http://www.excel.web.tr/f48/excel-ile-kare-bulmaca-yapymy-t13262.html

.

 

[iskelet]

Ömer bey o linki inceledim aslında o linkteki Security nin verdiği program tam istediğim gibi
tek fazlalığı ben kelimeleri soldan -sağa veya yukarıdan - aşağıya şekilde yerleştirmesini istiyorum. Ama Security nin programında kelimeler çaprazda yerleştiriliyor. Çapraz yerleştirmeler olmasaydı tam istediğim gibi programdı. Makrodan da anlamadığım için kendime göre düzenleyemedim.

 

[Ömer]

Pek ilgili olduğum konu değil, sadece konuyu arama butonundan aradığımda bulduğum linki paylaştım. Verdiğim linkin devamına sorunuzu iletiniz.

.

 

[iskelet]

Ömer bey
Sub BuildPuzzle()
Dim MaxWord As Long
Dim WordCount As Long
Dim MinSize As Long, MaxSize As Long
Dim Size As Long
Dim i As Long, j As Long, x As Long
Dim First As Long, Last As Long
Dim Temp1 As Long, Temp2 As String
Dim CurrWord As String
Dim CurrLen As Long
Dim Placed As Boolean
Dim PlacementType As Long
Dim RPos As Long, CPos As Long
Dim r As Long, c As Long

Randomize

Dim Kelimeler() As Words
MaxWord = Worksheets("Kelimeler").Range("Maxword")
WordCount = Worksheets("Kelimeler").Range("WordCount")

MinSize = Int(MaxWord * 1.6)
MaxSize = Int(MaxWord * 2.5)

' Prompt user for Bulmaca size
Do Until Size >= MinSize And Size <= MaxSize
Size = Val(InputBox("Bulmacanın kaç satır ve kaç sütündan oluşmasını isterisniz? Minimum ve Maximum Satır ve sütün sayısı " & MinSize & " ila " & MaxSize & ".", "....:::NURİ DAĞDELEN:::....Kelime Avı Bulmaca Sihirbazı", MinSize))
If Size = False Then End
Loop

Application.ScreenUpdating = False
' Build word list array
ReDim Kelimeler(WordCount)
For i = 1 To WordCount
Kelimeler(i).Word = UCase(Worksheets("Kelimeler").Cells(i, 1))
Kelimeler(i).Length = Len(Worksheets("Kelimeler").Cells(i, 1))
Next i

' Sort the array by work length
First = 1
Last = WordCount
For i = First To Last - 1
For j = i + 1 To Last
If Kelimeler(i).Length < Kelimeler(j).Length Then
Temp1 = Kelimeler(j).Length
Temp2 = Kelimeler(j).Word
Kelimeler(j).Length = Kelimeler(i).Length
Kelimeler(j).Word = Kelimeler(i).Word
Kelimeler(i).Length = Temp1
Kelimeler(i).Word = Temp2
End If
Next j
Next i

' Clear Bulmaca and set it up for next
With Worksheets("Bulmaca").Cells
.Clear
.Interior.ColorIndex = 15
.Rows.AutoFit
.ColumnWidth = 12.75
End With
Worksheets("Bulmaca").Activate
Range(Cells(1, 1), Cells(1, Size)).ColumnWidth = 3.71
Range(Cells(1, 1), Cells(Size, 1)).RowHeight = 21
With Range(Cells(1, 1), Cells(Size, Size))
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).Weight = xlThin
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Interior.ColorIndex = xlNone
End With

Application.ScreenUpdating = True

If Worksheets("Kelimeler").CheckBoxes("WatchIt").Value = xlOff Then Application.ScreenUpdating = False

' Place the words
For x = 1 To WordCount
CurrWord = Kelimeler(x).Word
CurrLen = Kelimeler(x).Length
Application.StatusBar = "Placing word " & x & " of " & WordCount

TryAgain:
Placed = False
PlacementType = RandBetween(1, 3)
If RandBetween(0, 1) = 0 Then CurrWord = ReverseWord(CurrWord)

Select Case PlacementType
Case 1 'Diagonal
RPos = RandBetween(1, Size - CurrLen + 1)
CPos = RandBetween(1, Size - CurrLen + 1)
For i = 0 To CurrLen - 1
If (Cells(RPos + i, CPos + i) = Mid(CurrWord, i + 1, 1)) Or (Cells(RPos + i, CPos + i)) = "" Then Placed = True Else Placed = False
If Placed = False Then GoTo TryAgain
Next i
If Placed = True Then
For i = 0 To CurrLen - 1
Cells(RPos + i, CPos + i) = Mid(CurrWord, i + 1, 1)
Next i
End If

Case 2 'Vertical
RPos = RandBetween(1, Size - CurrLen + 1)
CPos = RandBetween(1, Size)
For i = 0 To CurrLen - 1
If (Cells(RPos + i, CPos) = Mid(CurrWord, i + 1, 1)) Or Cells(RPos + i, CPos) = "" Then Placed = True Else Placed = False
If Placed = False Then GoTo TryAgain
Next i
If Placed = True Then
For i = 0 To CurrLen - 1
Cells(RPos + i, CPos) = Mid(CurrWord, i + 1, 1)
Next i
End If

Case 3 'Horizontal
RPos = RandBetween(1, Size)
CPos = RandBetween(1, Size - CurrLen + 1)
For i = 0 To CurrLen - 1
If (Cells(RPos, CPos + i) = Mid(CurrWord, i + 1, 1)) Or Cells(RPos, CPos + i) = "" Then Placed = True Else Placed = False
If Placed = False Then GoTo TryAgain
Next i
If Placed = True Then
For i = 0 To CurrLen - 1
Cells(RPos, CPos + i) = Mid(CurrWord, i + 1, 1)
Next i
End If
End Select

Next x

Application.StatusBar = "Filling in Remaining squares."

' Fill in remaining squares
For r = 1 To Size
For c = 1 To Size
If Cells(r, c) = "" Then Cells(r, c) = Chr(RandBetween(65, 90))
Next c
Next r

Application.StatusBar = False
End Sub



Function RandBetween(L, U) As Integer
' Returns a random integer between U and L
RandBetween = Int((U - L + 1) * Rnd + L)
End Function


Function ReverseWord(TheWord) As String
Dim i As Long
ReverseWord = ""
For i = Len(TheWord) To 1 Step -1
ReverseWord = ReverseWord & Mid(TheWord, i, 1)
Next i
End Function

bu kod daki hangi kısım kelimeleri çapraz veya sağdan- sola yerleştiriyor.