Incorporating feature of second macro into first?

[StargateFan]

This one will be a largish post because I'm not familiar with which
parts are vital and which aren't. The challenge is that I've been
using the workbook with previous code and today I just stumbled upon
code that incorporates one feature I need but the workbook is
unpolished and I can't start using it over the earlier one as that's
the one I unfortunately worked on. Goodness knows why this one ended
up lost but it did.

Here's the initial code. Its purpose is to create a quotefall
puzzle. I don't remember who r.e.s. is nor which group I recvd this
code in. If you are r.e.s., pls advise. It's been nearly 3 years so
memory isn't so good from that long ago <g>.


*******************************************
'Quotefalls Generator (r.e.s. 2007/2/6)

Sub Make_Quotefalls_Puzzle()
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("Quotefalls").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("Quotefalls").Range("4:20").Clear
'write the column-sorted quotation
For i = 1 To imax
For j = 1 To jmax
Worksheets("Quotefalls").Range("B4Z30").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("Quotefalls").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("Quotefalls").Range(Cells(4, 2), Cells(4 + 2 * imax -
1, 2 + jmax - 1)) _
' .CopyPicture xlScreen, xlBitmap
Worksheets("Quotefalls").Range("A1:A1").Select

End Sub 'Quotefalls

'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
*******************************************



I'm going to paste the 2nd book's code, hope it isn't too confusing:



*******************************************

'Quotefalls Generator (r.e.s. 2007/2/25)

Sub Quotefalls()
Dim A(10, 50) 'array for ascii codes of quote letters (unsorted)
Dim B(10, 50) 'array for sorted quote letters
Dim x(500) 'array for possibly-merged columns
Dim s, t, u 'strings
Dim ascii 'ascii code of a letter
Dim i, j, k, imax, jmax, nc
Dim Qf_Range 'maximum range for display of quotefalls
Dim fill 'indicates whether to fill-in the solution

'get the input quotation from the workbook
s = Cells(2, 2)

'get the number of columns to have merged clues
nc = CInt(Cells(8, 32))

'get the choice of whether to fill in the solution
fill = Cells(8, 41)

'set the display range
Set Qf_Range = Range("B13Z100")

'initialise arrays A, B
For i = 1 To 10
For j = 1 To 50
A(i, j) = Asc(" ") 'ascii code for space
B(i, j) = " " 'space
Next
Next

'place the quote's ascii codes in array A
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
If jmax > 50 Then
MsgBox ("The number of columns cannot exceed 50.")
Exit Sub
End If
End If
A(i, j) = ascii
j = j + 1
Else
j = 1
i = i + 1
If i > 10 Then
MsgBox ("The number of rows cannot exceed 10.")
Exit Sub
End If
End If
Next

If nc > jmax Then
MsgBox ("Column group size cannot exceed the number of
columns.")
Exit Sub
End If

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 Step nc
'kmax = max number of columns in current merged group
kmax = nc
If j + nc - 1 > jmax Then kmax = (jmax Mod nc)
For i = 1 To imax
For k = 1 To kmax
ascii = A(i, j + k - 1)
If ((ascii >= 65 And ascii <= 90) Or (ascii >= 97 And
ascii <= 122)) Then
x(nc * (i - 1) + k) = ascii
Else
x(nc * (i - 1) + k) = Asc(" ")
End If
Next
Next
QSort x, 1, nc * imax
ii = 0
k = 0
For i = 1 To nc * imax
If x(i) <> Asc(" ") Then
If k = 0 Then ii = ii + 1
B(ii, j + k) = Chr(x(i))
k = (k + 1) Mod kmax
End If
Next
For i = 1 To nc * imax
x(i) = Asc(" ")
Next
Next

Qf_Range.Clear
'write the column-sorted quotation
For i = 1 To imax
For j = 1 To jmax
Qf_Range.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
If (j - 1) Mod nc = 0 Then
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
If j = jmax Then
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
Next
Next

'write the quotation template (including the solution if fill = Y
or y)
For i = 1 To imax
For j = 1 To jmax
Qf_Range.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
Else
If (fill = "Y" Or fill = "y") Then Selection.Value =
Chr(ascii)
End If
Next
Next
Cells(2, 2).Select

End Sub 'Quotefalls

'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
*******************************************

The reason for posting both will now be made clear. Though the
procedure is clunky, if I put a Y in a box, then the puzzle would be
re-created _with_ the solution.

I'd rather not have that method. I'd rather assign a specific button
in my floating toolbar to it (XL2003) rather than having to actually
type in specific code.

I was hoping I could somehow figure this out on my own but no go. I
tried creating a second button and assigned the 2nd script to it but
when it looped without doing anything remembered I was missing
inputing the "Y". So ended up having to come here anyway.

I hope that it's just a question of adding something simple to the
first script that is found in the second one without user input. Just
the fact that the solution button is being pressed should be the go-
ahead to re-create the same identical puzzle with the solution dropped
down into the boxes instead of being empty.

*****************************
"Y" part:

'write the quotation template (including the solution if fill = Y or
y)
For i = 1 To imax
For j = 1 To jmax
Qf_Range.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
Else
If (fill = "Y" Or fill = "y") Then Selection.Value =
Chr(ascii)
End If
Next
Next
Cells(2, 2).Select
*****************************

Thank you so much in advance! This would be the best Xmas present to
finally have a working file where I don't manually have to enter in
the solution.

Thanks! D

 

[StargateFan]

Can anyone suggest what to do? I'm stuck with this complex project.
I have 2 workbooks. One is highly complex and works very well, the
other simple and doesn't do the job completely. Yet the second has one
function that is very important - it has capability later one does not
of creating the puzzle with the answer key inside it by clicking a
button.

I've been searching all over for who helped me with this but can't
find author.

Is there any solution to this type of thing? What do you all do when
you need an answer but there is no response?

I'd be willing to email the file that is missing the answer key
button. Perhaps that would be easier than trying to decipher it this
way.

Thanks!

 

[Pete_UK]

Here's a link to your thread from 2007:

http://groups.google.com/group/micr...8688d08?lnk=gst&q=Quotefalls#52eb964b38688d08

but you didn't seem to get any help that time around, so you must have
posted in another forum.

Hope this helps.

Pete

 

[StargateFan]

Here's a link to your thread from 2007:

http://groups.google.com/group/microsoft.public.excel.programming/bro...

but you didn't seem to get any help that time around, so you must have
posted in another forum.

Hope this helps.

Pete

Pete, how did you do that?? Even seeing it on my site I don't
remember putting that up. It's there so I did but sheesh! This bad
memory thing is the pits.

No, I really don't remember where I got this other file. I
consolidated all my files from the USB flash drive before posting here
and in the backups this one turned up. I do remember that it was
someone not from this forum that did up this file because s/he was
doing up something similar. But that information is gone. I combed
through all my source documents and nowhere can I find where I contact
this person or how I even got this file to begin with.

The file uploaded above is the old style one. I somehow got a newer
file that does do the answer key but that doesn't have other vital
things on it. And I can't seem to incorporate both. The challenge
is that this was in the early days of my USB flash drive use. I now
have a great system of backing up all newly created XL files into a
folder where as I create complex XL documents, I save a time-stamped
copy to that folder. But this file (naturally!) predates that process
by a few weeks or months only. Unfortunately, since it's for a
website I want to build, it's pretty important. In fact, since it's
for my own personal business and not company business, I consider it
more important than any other document.

Well, I'll continue looking. I'm not sure what I'll do if I can't
figure it out. I took the code from both files and tried to get them
to work together but no go. Wish I had the ability to program better
but I'm a plodder at best.

Thanks. Still, I'll update that file on the site, just in case. It's
definitely not the main one I'm working with now. Thanks for this.

 

[Pete_UK]

Pete, how did you do that??

I just did a Google search for Quotefalls in the programming group (as
I assumed that was where you got it from).

You've not really described what the difference is between the two
versions, nor what it is that you want to incorporate from the second
one into the first. I assume it is the solution, but is this to go
below the puzzle, or in another sheet, or offered as an option?

If you can describe in more detail what they currently do and what you
want them to do then I might take a look at it for you. However, I'm a
bit busy this week, so I can only work on it as time allows.

Hope this helps.

Pete

 

[Pete_UK]

Incidentally, in widening the Google search to all groups I think I
found the thread you were looking for:

http://groups.google.com/group/rec....7dbbf477f1fe025/d7b1c21afec281cb?q=Quotefalls

The poster r.e.s. seems to have changed his email address a few times,
and the links he provided are no longer valid.

Hope this helps.

Pete