Solved: Fill Table cell

[Dave]

Using XL VBA, I am trying to generate a Word table output like this...
Art.................Test
Banana............Test
In this example, the Word table has 2 columns and 2 rows. I would like column 1 to "fill" with "." 's to the right of the column 1 Text up to the left edge of column 2. The problem of course is that the Text contents of Column 1 is variable length. The following XL VBA code, places the contents of Sheet1 A1:B2 in the Word table. It doesn't work as character width varies (ie. using LEN is useless). Any suggestions welcome. Dave

Sub WordTableDots()
Dim ObjWord As Object, WrdDoc As Object
Dim Temp As String, Cnt As Integer
'no Word reference required

On Error GoTo Erfix
'open existing word .doc file
Set ObjWord = CreateObject("Word.Application")
Set WrdDoc = ObjWord.Documents.Open(Filename:="D:\test.doc")
'clear doc
With WrdDoc
.Range.Delete
End With
'add table
With WrdDoc
.Tables.Add ObjWord.Selection.Range, _
NumRows:=2, NumColumns:=2
End With
'add contents to table cells
For Cnt = 1 To 2
'add dots to fill column one of table
Temp = Sheets("Sheet1").Range("A" & Cnt)
If Len(Temp) <= 30 Then
Do
Temp = Temp + "."
Loop Until Len(Temp) = 30
End If
WrdDoc.Tables(1).Cell(Cnt, 1).Range = Temp
WrdDoc.Tables(1).Cell(Cnt, 2).Range = _
Sheets("Sheet1").Range("B" & Cnt)
Next Cnt
'remove gridlines
ObjWord.ActiveWindow.View.TableGridlines = False
WrdDoc.Close savechanges:=True
Set WrdDoc = Nothing
ObjWord.Quit
Set ObjWord = Nothing
MsgBox "Finished"
Exit Sub

Erfix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
ObjWord.Quit
Set ObjWord = Nothing
End Sub

[fumei]

1. why are you "clearing" the test.doc?

2. why are you even doing this? What is the purpose of putting in those extraneous dots?

Do you have .AllowAutoFit = True? This is the default. if you do, the cel size willchange as well. It sounds like it should be False. In conjunction with this, what is the table size? Are you accepting the default?

3. This is almost impossible, as - unless you are using fixed-width fonts - the kerning of the characters will make a difference.

Take a look.

Art = 3 characters, yes?
Banana = 6 characters.

In theory, to "fill" the cell width with dots should take 3 LESS characters with "Banana", yes?

But it does NOT.

In the demo doc attached, click "Fill With Dots" on the top toolbar. It does what you ask for, with the addition on two instances of "wow". One full caps, one not.

The code take a count - equivalent to your Len(Temp) < 30 - of the cell. However.....

Because of kerning, "wow" takes up less space than "WOW", as you can see.

Even though they have the same character count - a counting via Len - the number of dots required to "fill" the cell is different.

The "WOW" has an extra 5 dots, the "wow" has two.

Here is the code.
Const CellLen As Long = 67
Function TheDots(lngIn As Long) As String
Do
TheDots = TheDots & "."
Loop Until Len(TheDots) = lngIn
End Function

Sub FillWithDots()
Dim oTable As Table
Set oTable = ActiveDocument.Tables(1)
With oTable
.Cell(1, 1).Range.Text = "Art" & _
TheDots(CellLen - Len("Art"))
.Cell(2, 1).Range.Text = "Banana" & _
TheDots(CellLen - Len("Banana"))
.Cell(3, 1).Range.Text = "WOW" & _
TheDots(CellLen - Len("WOW"))
.Cell(4, 1).Range.Text = "wow" & _
TheDots(CellLen - Len("wow"))
End With
End Sub

[Dave]

Thanks Fumei. This was better?

Const CellLen As Long = 62


It seemed to yield the same result as using LEN? Kerning... that is the word I was looking for. My apologies for not being clearer. The table data is located in XL and this is XL VBA. The .doc is cleared so that the new stuff isn't appended to the old stuff. The reason for the code is to visually extend the contents of column 1 to the contents of column2. I did mention that LEN didn't work and I did try to explain my understanding of why. I've messed around for several hours trying to address the "kerning" issue. It seems that you should be able to somehow know where the end of the Text that is visual in a table cell is in relation to the start of the next table cell. Again, I greatly appreciate your assistance. Dave

[fumei]

"The .doc is cleared so that the new stuff isn't appended to the old stuff. "

Use a template. That is what they are for.

"The reason for the code is to visually extend the contents of column 1 to the contents of column2. "

Huh? I do not know what you really mean by that.

" It seems that you should be able to somehow know where the end of the Text that is visual in a table cell is in relation to the start of the next table cell."

By looking at it?

I do not understand the significance of:

text __________| next column
(ignore the underscore, this system does not process spaces)

versus

text.................| next column

[Dave]

Maybe "visually" is not as desriptive as I had hoped. The dots just need to fill in the space between column 1 Text and column 2. I was just hoping to learn abit more about Word tables by helping out here..
http://www.mrexcel.com/forum/showthread.php?t=453071
Sort of explains the dots and I thought that it would be interesting to learn how to do it. Hope your still enjoying OUR golden goal. Dave

[fumei]

Well good luck. I fail to see any use of the dots, but that is what you want to do, what can I say?

Personally, I find the dot leaders distracting (and kind of annoying).

Why not make the text in column1 right-aligned?

_______Art | next column
____Banana| next column

I live in Vancouver. My ears are still ringing from the noise after that goal.

[fumei]

BTW: even not using a template, there is no need to "clear" your document. You can put whatever you want, where ever you want. If you want to replace something (rather than appending), this can be done.

[Dave]

I was hoping to learn how to Kern :) It really doesn't matter to me... just seems abit challenging. Not clearing the .doc never seems to work for me so I have just resolved to always clear the .doc before I try to put stuff in it from XL. WE can go back to being quietly smug. ALL is well once again. Any thought on how to read the kerning and adjust the dots? Dave
On edit: Can you tell when a table cell "over flows" into the next table cell assuming that the column width remains static and there is no wordwrap? Maybe add characters to the existing text until the overflow. The count of characters added could then be used to determine the relative distance to the end of the cell. Or maybe not?

[fumei]

How to kern? No, YOU do not kern. If you use a True-Type font (and most of us do) then the kern is a function of the printer driver.

"Not clearing the .doc never seems to work for me so I have just resolved to always clear the .doc before I try to put stuff in it from XL."

You would never have this problem if you used a template.

"On edit: Can you tell when a table cell "over flows" into the next table cell assuming that the column width remains static and there is no wordwrap? Maybe add characters to the existing text until the overflow. The count of characters added could then be used to determine the relative distance to the end of the cell. Or maybe not?"


Maybe not. Which characters????? A "I" (narrow), or a "W" (wide)?

Would it possible? I suppose so, but I for one would not bother to do the extraordinary amount of work/coding that may be involved. As I fail to see any point to it. I am not even sure it IS possible, but in theory it could be.

But note the example doc I posted.

"Art" and "WOW" both have three characters. LOOK at the difference! Yes, the "Art" cell seems to fit, but the "WOW" cell certainly does not.

What does that mean?

It means you would have to test and check every single character combination inserted into each cell. And not for the character count, because with kerning, the count is not what matters. It is the shape of the character.

What a waste of time and resources. Or so it seems to me.

[Dave]

I was suggesting that a single character be used and the character count would then represent the relative distance IF indeed a cell overflows? Anyways, the task has been successful in helping me learn a bit more. Thank you for your time and input. If I happen upon a satisfactory resolution I will post (don't hold your breath). Dave

[fumei]

Oh indeed. Please do post something if you come up with something.

[Dave]

It seems like FitText offers a reasonable facimile of a solution (not fool proof... so maybe I shouldn't use it). Anyways, Bob at the link must have found a solution else where (...or maybe his ISP is down or...maybe a herd of water buffalos stomped his pc... or whatever). He will have to find this thread to resolve his request. To recap the task, the XL data layout in sheet 1 columns A, B and C....
14141 50 Cent In Da Club
14142 50 Cent Just A Little Bit
14143 50 Cent P.I.M.P

5625 5Th Dimension The Aquarius - (Medley)
5615 5Th Dimension The Let The Sunshine In -(Medley)
3535 5Th Dimension Angles And Rhymes

Output to Word like....
50 Cent
In Da Club ....................................... 14141
Just A Little Bit ................................ 14142
P.I.M.P ......................................... 14143

5 Th Dimension
The Aquarius - (Medley) ......................... 5625
The Let The Sunshine In -(Medley) ................ 5615
Angles And Rhymes ................................ 3535

But with some formatting. Combing LEN and FitText seems to work if you jigger with the LEN (ie. 50 in this eg). Of interest was the finding that setting a table cell's format (including fitText) continues on to the next row (not column) until the formatting is changed. Ergo, I thought I should post the entire code to illustrate. It has been interesting. Dave
ps. the adding dot thing will take a long time if you have a lengthy list.

Option Explicit
Sub XLToWordTable()
Dim ObjWord As Object, WrdDoc As Object
Dim Lastrow As Integer, Cnt As Integer, Tcnt As Integer
Dim TestStr1 As String, TestStr2 As String, Temp As String
'sheet1 A = ID number
'sheet1 B = Artist name
'sheet1 C = Song
'no Word reference required

On Error GoTo Erfix
'open existing word .doc file ie. "D:\tabletest.dot"
'change file path to suit
Set ObjWord = CreateObject("Word.Application")
Set WrdDoc = ObjWord.Documents.Open(Filename:="D:\test.doc")
'clear doc
With WrdDoc
.Range(0, .Characters.Count).Delete
End With
With Sheets("Sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'add table
With WrdDoc
.Tables.Add ObjWord.Selection.Range, NumRows:=1, NumColumns:=2
End With
TestStr1 = vbNullString
'loop XL sheet
For Cnt = 1 To Lastrow
TestStr2 = CStr(Sheets("Sheet1").Range("B" & Cnt))

If TestStr1 <> TestStr2 Then
Tcnt = Tcnt + 1 'table row cnt
WrdDoc.Tables(1).Cell(Tcnt, 1).FitText = False
WrdDoc.Tables(1).Cell(Tcnt, 1).Range = _
CStr(Sheets("Sheet1").Range("B" & Cnt))
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Bold = True
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Italic = False
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Size = 14

WrdDoc.Tables(1).Rows.Add
Tcnt = Tcnt + 1

Temp = CStr(Sheets("Sheet1").Range("C" & Cnt))
'add "."'s to make standard LEN of input string
'*** change 50 to whatever
If Len(Temp) <= 50 Then
Do
Temp = Temp + "."
Loop Until Len(Temp) = 50
End If
WrdDoc.Tables(1).Cell(Tcnt, 1).Range = Temp

'fit new string to whole table cell length
WrdDoc.Tables(1).Cell(Tcnt, 1).FitText = True
'add format to table cell
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Bold = False
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Italic = True
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Size = 12

If Sheets("Sheet1").Range("A" & Cnt) <> vbNullString Then
'add data to table column 2
WrdDoc.Tables(1).Cell(Tcnt, 2).Range = _
CStr(Sheets("Sheet1").Range("A" & Cnt))
WrdDoc.Tables(1).Rows.Add
End If

TestStr1 = CStr(Sheets("Sheet1").Range("B" & Cnt))

Else
Tcnt = Tcnt + 1

Temp = CStr(Sheets("Sheet1").Range("C" & Cnt))
'add "."'s to make standard LEN of input string
'*** change 50 to whatever
If Len(Temp) <= 50 Then
Do
Temp = Temp + "."
Loop Until Len(Temp) = 50
End If
WrdDoc.Tables(1).Cell(Tcnt, 1).Range = Temp

'fit new string to table cell length
WrdDoc.Tables(1).Cell(Tcnt, 1).FitText = True
'add format to table cell
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Bold = False
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Italic = True
WrdDoc.Tables(1).Cell(Tcnt, 1).Range.Font.Size = 12
'add data to table column 2
WrdDoc.Tables(1).Cell(Tcnt, 2).Range = _
CStr(Sheets("Sheet1").Range("A" & Cnt))
WrdDoc.Tables(1).Rows.Add
End If
Next Cnt
'remove table gridlines
ObjWord.ActiveWindow.View.TableGridlines = False
WrdDoc.Close savechanges:=True
Set WrdDoc = Nothing
ObjWord.Quit
Set ObjWord = Nothing
MsgBox "Finished"
Exit Sub

Erfix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
ObjWord.Quit
Set ObjWord = Nothing
End Sub

on edit: This is XL VBA