Reply to thread

Message: [QUOTE="StargateFan, post: 6219483"] On Sun, 11 Mar 2007 07:17:10 -0500, StargateFan [snip] I don't know what else to say. I'm hoping that someone can help with this so trying to figure out how to make this easier. I don't know what else to do, but going to give it a try. The scripting is beyond me. I can't get anything to work. But the process I know will be simple for anyone in this group as you all know so much. I've uploaded another example. Here is what the current page's scripts are generating (an example): [URL]http://www.angelfire.com/art2/hypatia/1Other/Puzzles/Quotefalls_Puzzle__p.gif[/URL] This is what is actually needed, as it's easier to generate the solution then just erase the solution part itself to create the puzzle (sort of like working backwards <g>): [URL]http://www.angelfire.com/art2/hypatia/1Other/Puzzles/Quotefalls_Puzzle_a.gif[/URL] This is the code that generates just the puzzle part. What's needed is that the text be dumped below the scrambled letters part to form the "solution" part: **************************************************************************************************************** 'Quotefalls Generator (r.e.s. 2007/2/6) Sub Quotefalls() Dim A(100, 100) 'array for ascii codes of quote letters (unsorted) Dim B(100, 100) 'array for sorted quote letters Dim x(100) 'array for column Dim s, t, u 'strings Dim ascii 'ascii code of a letter Dim i, j, k, imax, jmax 'get the input quotation from the workbook s = Worksheets("Sheet1").Range("B2:B2") 'initialise A and B For i = 1 To 100 For j = 1 To 100 A(i, j) = Asc(" ") 'ascii code for space B(i, j) = " " 'space Next Next 'create array A from the quote i = 1 j = 1 jmax = 1 For k = 1 To Len(s) ascii = Asc(Mid(s, k, 1)) If (ascii <> 10) Then If j > jmax Then jmax = j End If A(i, j) = ascii j = j + 1 Else j = 1 i = i + 1 End If Next imax = i 'imax = number of rows of text ascii in A 'jmax = number of columns 'create sorted array B (the "quotefalls") For j = 1 To jmax For i = 1 To imax ascii = A(i, j) If ((ascii >= 65 And ascii <= 90) Or (ascii >= 97 And ascii <= 122)) Then x(i) = ascii Else x(i) = Asc(" ") End If Next QSort x, 1, imax ii = 0 For i = 1 To imax If x(i) <> Asc(" ") Then ii = ii + 1 B(ii, j) = Chr(x(i)) End If Next Next Worksheets("Sheet1").Range("4:20").Clear 'write the column-sorted quotation For i = 1 To imax For j = 1 To jmax Worksheets("Sheet1").Range("B4:DZ30").Cells(i, j).Select Selection.Value = B(i, j) With Selection.Interior .Color = RGB(255, 255, 200) .Pattern = xlSolid End With If i = 1 Then With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Next Next 'write the quotation template For i = 1 To imax For j = 1 To jmax Worksheets("Sheet1").Range("B4:B4").Cells(imax + i, j).Select Selection.BorderAround _ Color:=Black, Weight:=xlThin ascii = A(i, j) If Not ((ascii >= 65 And ascii <= 90) Or (ascii >= 97 And ascii <= 122)) Then If ascii <> 32 Then Selection.Value = "'" & Chr(ascii) 'single-quote prefix for proper display Else With Selection.Interior .Color = RGB(0, 0, 0) .Pattern = xlSolid End With End If End If Next Next 'uncomment next line to automatically copy a quotefalls picture to the clipboard 'Worksheets("Sheet1").Range(Cells(4, 2), Cells(4 + 2 * imax - 1, 2 + jmax - 1)) _ ' .CopyPicture xlScreen, xlBitmap Worksheets("Sheet1").Range("A1:A1").Select End Sub 'Quotefalls Sub Copy_to_Clipboard() Worksheets("Sheet1").Range("B2:B2").Cells(imax, jmax).CopyPicture xlScreen, xlBitmap End Sub 'quicksort subroutine Sub QSort(aData, iaDataMin, iaDataMax) Dim Temp Dim Buffer Dim iaDataFirst Dim iaDataLast Dim iaDataMid ' Start current low and high at actual low/high iaDataFirst = iaDataMin iaDataLast = iaDataMax ' Error! If iaDataMax <= iaDataMin Then Exit Sub ' Find the approx midpoint of the array iaDataMid = (iaDataMin + iaDataMax) \ 2 ' Pick a starting point ' assume the data *might* be in semi-sorted order already! Temp = aData(iaDataMid) Do While (iaDataFirst <= iaDataLast) 'Comparison here Do While (aData(iaDataFirst) < Temp) iaDataFirst = iaDataFirst + 1 If iaDataFirst = iaDataMax Then Exit Do Loop 'Comparison here Do While (Temp < aData(iaDataLast)) iaDataLast = iaDataLast - 1 If iaDataLast = iaDataMin Then Exit Do Loop ' if low is <= high then swap If (iaDataFirst <= iaDataLast) Then Buffer = aData(iaDataFirst) aData(iaDataFirst) = aData(iaDataLast) aData(iaDataLast) = Buffer iaDataFirst = iaDataFirst + 1 iaDataLast = iaDataLast - 1 End If Loop ' Recurse if necessary If iaDataMin < iaDataLast Then QSort aData, iaDataMin, iaDataLast End If ' Recurse if necessary If iaDataFirst < iaDataMax Then QSort aData, iaDataFirst, iaDataMax End If End Sub 'QSort **************************************************************************************************************** Thanks! Much appreciated. Hope that someone can help out with this. Cheers. :oD [/QUOTE]

Verification