Solved: Creating palm cards for a speech

[peacenik]

I write a lot of stuff in Excel but am not too familiar with VBA for Word.

My kids do speeches for school regularly and I get the job of manually breaking up the speech into palm card sized chunks. I do this by creating a two column table and cutting and pasting in. What I would like to do is to determine the number of characters (plus or minus) that each card should contain and break the speech down automatically, but retaining full sentences. Can someone give me some pointers as to how I would scan looking for breaks. I was thinking I would scan through looking for groupings, drop the text into an array and then drop it into the table cells, finally number each cell.

I am not looking for someone to write this for me, just some hints on how to handle the text.

Thanks in advance for your help.

[mdmackillop]

Hi Peacenick
Welcome to VBAX.
I made up this item a short time ago, to automatically split text into standard height cells in Excel. With a little manipulation, adjusting the "split" ratio and searching for a period instead of a space, I think it could be one solution.
Regards
MD
http://www.vbaexpress.com/kb/getarticle.php?kb_id=481

[peacenik]

Thanks for the quick response. It is not what I was thinking, but I think it will do nicely. Don't know why it didnt occur to me to pull the text to my 'home turf'.

I will let you know how I go.

[mdmackillop]

Hope it helps. You can always pass the results back to Word for better formatting etc.

[peacenik]

I took your concept and built this:
[VBA]
Sub MakeCards()
Dim TextBucket As String
Dim palmcards(99) As String
Dim StrLen As Integer
WrapLength = 280

Application.ScreenUpdating = False
For Each cell In Range("A1:A999")
If Right(cell.Value, 1) <> "." Then cell.Value = cell.Value & "."
TextBucket = TextBucket & " " & cell.Value
Next

Do
StrLen = Len(TextBucket)
If StrLen > WrapLength Then
For j = WrapLength To 0 Step -1
If j = 0 Then
WrapLength = WrapLength + 5
Exit For
End If
If Mid(TextBucket, j, 1) = "." Then
palmcards(Counter) = Left(TextBucket, j)
TextBucket = Right(TextBucket, StrLen - j)
Counter = Counter + 1
WrapLength = 280
Exit For
End If
Next
End If
Loop Until Len(TextBucket) <= WrapLength
Range("A1:a999").ClearContents
Sheets.Add
ActiveSheet.Name = InputBox("Enter Speech Title", "Speech Title")
Range("a1").Activate
For i = 0 To Counter
If i Mod 2 = 0 Then
ActiveCell.Offset(i, 0).Value = palmcards(i)
ActiveCell.Offset(i + 1, 0).Value = i + 1
ActiveCell.Offset(i, 0).Select
With Selection
.Font.Size = 14
.VerticalAlignment = xlTop
.WrapText = True
.ColumnWidth = 43
End With
ActiveCell.Offset(1, 0).Select
With Selection
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
End With

Else
ActiveCell.Offset(i - 1, 1).Value = palmcards(i)
ActiveCell.Offset(i, 1).Value = i + 1
ActiveCell.Offset(i - 1, 1).Select
With Selection
.Font.Size = 14
.VerticalAlignment = xlTop
.WrapText = True
.ColumnWidth = 43
End With
ActiveCell.Offset(1, 0).Select
With Selection
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
End With
End If
Range("a1").Activate
Next
Cells.Select
Cells.EntireRow.AutoFit
Range("A1").Select
Cells.Replace What:=". .", Replacement:=".", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

For k = 0 To Counter
If k Mod 2 = 0 Then
Range("A" & k + 1 & ":A" & k + 2).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Else
Range("B" & k & ":B" & k + 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If
Next
Application.ScreenUpdating = True
End Sub

Sub ImportText()
Range("a1").Activate
ActiveSheet.Paste
End Sub
[/VBA]