Coding help please.

[Robert]

Could someone please help me with code for a routine which is part of a
longer macro. At the point where the routine is needed, my document
contains two similar tables. Table 2 is a look-up table from which data
is copied into Table 1 before being deleted.
Each cell contains just one word - apart from a few blanks. Without
using "Find" (for complex reasons) I need to scan Table 1 Column 1 for
words carrying a blue background formatting. When one is found,
attention turns to Table 2 Column 1 which must then be scanned for a
matching word (minus the formatting).
If a match is found, further words from the "matching" row in Table 2
Columns 2 and 3 (but not Column 1) are now copied to Table 1 Columns 2
and 3 (that is, back into the row where the scanning stopped). The
cells which receive these words will be blank.
If no match is found, nothing is written into Table 1 and the scanning
resumes with the next word from Table 1 Column 1, stopping at the end
of the Column.
"Find" would be quicker, I know, but speed is not important in this
case.
I am quite unable to get my head round this, so any help will be most
gratefully received.
Thanks in advance,
Robert

 

[Helmut Weber]

Hi Robert,

Each cell contains just one word - apart from a few blanks.

"Each cell" in which table, or in both tables?

Does that mean there might be spaces in a cell
in addition to a word, or that there are cells that contain
only spaces or that there are cells containing nothing?

I need to scan Table 1 Column 1 for words carrying a blue background formatting.

What is "background formatting"?
Do you mean "highlighting?"

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Robert]

Hello Helmut,
Nice to "talk" to you again. Thanks for your prompt reply.
Sorry about my ambiguities; you are quite right, I should have been
more precise.

Each cell contains just one word - apart from a few blanks.
"Each cell" in which table, or in both tables?
Does that mean there might be spaces in a cell

in addition to a word, or that there are cells that contain
only spaces or that there are cells containing nothing?

This should read: Each cell in both tables contains just one word -
apart from some cells which are blank and contain nothing. A cell
either contains a word (without spaces) or nothing (other than the cell
marker). In any Table 1 row which contains a blue-shaded word in
Column 1, the cells in Columns 2 and 3 of that row are always "empty"
and contain just the cell marker.

I need to scan Table 1 Column 1 for words carrying a blue background formatting.
What is "background formatting"?
Do you mean "highlighting?"

No, not highlighting, but Shading, placed there by another macro using
Font.Shading.BackgroundPatternColor = wdColorBlue

Thank you for your patience in deciphering my description.
Sincerely,
Robert.

 

[Helmut Weber]

Hi Robert,

to get you going, have a look at this one:

Sub Test408()
' ---
Dim lClr As Long ' color
If Environ$("Username") = "WeberHe" Then
lClr = wdColorYellow
Else
lClr = wdColorBlue
End If
' ---
Dim oTbl(1 To 2) As Table
Set oTbl(1) = ActiveDocument.Tables(1)
Set oTbl(2) = ActiveDocument.Tables(2)
Dim oRow As Row
Dim rWrd As Range ' range of a word
For Each oRow In oTbl(1).Rows
Set rWrd = oRow.Cells(1).Range.Words(1)
If rWrd <> Chr(13) & Chr(7) Then
If rWrd.Font.Shading.BackgroundPatternColor = lClr Then
rWrd.Select ' for testing, not necessary
MsgBox rWrd.Information(wdEndOfRangeRowNumber)
Stop
End If
End If
Next
End Sub

Of course, oTbl(2) isn't used yet, and I prefer yellow,
as black letters on blue background hurt my eyes.

If this works for you, we will precede.

Greetings from Bavaria, Germany
Helmut Weber, MVP WordVBA
"red.sys" & chr(64) & "t-online.de"

 

[Robert]

Guten Morgen Helmut,
Thank you for Sub Test408. It correctly identifies the rows containing
the blue shading in Table 1. I was puzzled by your ref. to "black
letters" because mine are all white (on blue background). I had
assumed this change was automatic but, on checking, I find that the
Font.Color in the original macro is set to wdColorWhite. White on blue
will not drive you to your Ophthalmologist, I think.
I'm looking forward to seeing the "loopy" part.
Herzlichen Dank nochmals.
Robert.

 

[Helmut Weber]

Hi Robert,

how about this modified one?
If I got you right, then (just in principle):

Sub Test409()
' ---
Dim lClr As Long ' color
If Environ$("Username") = "Helmut Weber" Then
' I am on another machine now
lClr = wdColorYellow
Else
lClr = wdColorBlue
End If
' ---
Dim oTbl(1 To 2) As Table
Set oTbl(1) = ActiveDocument.Tables(1)
Set oTbl(2) = ActiveDocument.Tables(2)
Dim lRow As Long ' counter for rows
Dim rWrd As Range ' range of a word
For lRow = 1 To oTbl(1).Rows.Count
Set rWrd = oTbl(1).Rows(lRow).Cells(1).Range.Words(1)
If rWrd <> Chr(13) & Chr(7) Then
If rWrd.Font.Shading.BackgroundPatternColor = lClr Then
oTbl(1).Cell(lRow, 2).Range = _
oTbl(2).Cell(lRow, 2).Range.Words(1)
oTbl(1).Cell(lRow, 3).Range = _
oTbl(2).Cell(lRow, 3).Range.Words(1)
End If
End If
Next
End Sub

You may have to adapt this or that,
as there are words in english, which contain spaces,
like "killer whale" or "singer songwriter"
according to the theories I've learned about.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Robert]

Hello again Helmut,
Sub Test109 was very interesting, thanks a lot. But I think it needs
one more loop to search Table2 for the required word. This is because
the single value of lRow is used in both tables. It follows that the
transferred word is currently taken from Table2 at the lRow setting of
Table1. The "transferred" words therefore bear no relationship with the
"blue word" in Column1 of Table1. With today's test data, the lRow
value for Table2 was "out" by a value of 12.

There are a few other things wrong, but they may all be remedied by
your solution to the above.
One thing I should have mentioned: Table 1 has a Header Row, whereas
Table2, being only temporary and filled from a text file, doesn't need
one.

Three things you might like to check afterwards:
(1) The case where there is NO match in Table2 & nothing is to be
written into Table 1.
(2) Currently, nothing (apart from a Paragraph mark) is yet written
into Column 3 of Table 1. There should be a few words in that Column,
though many rows will normally be "empty"
(3) This Paragraph mark ( = pilcrow) which is written into all the
modified rows at Column3 distorts Table 1's formatting by adding an
extra line to the whole row. Could this be avoided without losing the
"AutoFitContent" feature? If necessary I could modify the text file by
adding (say) a "%" or even a space into every empty cell. There would
thus always be something to "transfer".

"Bon courage" (as the French say) and renewed thanks,
Robert.

 

[Helmut Weber]

Hi Robert,

so far for finding the first word in column 1 of table 1
in a row greater 1, which has a given BackgroundPatternColor.
And ...
finding the first similar word 1 in column 1 of table 2.
What to do next?

Sub Test410()
' ---
Dim lClr As Long ' color
If InStr(Environ$("Username"), "Weber") > 0 Then
lClr = wdColorYellow
Else
lClr = wdColorBlue
End If
' ---
Dim oTbl(1 To 2) As Table
Set oTbl(1) = ActiveDocument.Tables(1)
Set oTbl(2) = ActiveDocument.Tables(2)
Dim lRw1 As Long ' counter for rows in table 1
Dim lRw2 As Long ' counter for rows in table 2
Dim sTmp As String
Dim rWr1 As Range ' range of a word in table 1
Dim rWr2 As Range ' range of a word in table 2
For lRw1 = 2 To oTbl(1).Rows.Count
Set rWr1 = oTbl(1).Rows(lRw1).Cells(1).Range.Words(1)
If rWr1 <> Chr(13) & Chr(7) Then
If rWr1.Font.Shading.BackgroundPatternColor = lClr Then
rWr1.Select ' testing
Stop
For lRw2 = 1 To oTbl(2).Rows.Count
Set rWr2 = oTbl(2).Rows(lRw2).Cells(1).Range.Words(1)
If rWr1 = rWr2 Then
rWr2.Select ' testing
Stop
' found first word in table 2
' equal to current word in table 1
' right? what to do now
End If
Next
End If
End If
Next
End Sub

Are you a native speaker of german?

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Robert]

Helmut, lieber Schlaumeier,
Sub Test 410 works perfectly. Congratulations & many thanks! So what
comes next?

At the end of the first rotation we have found the same word in Tables
1 and 2, Col. 1. We have therefore found the Row (in each table) on
which to work. In Table1 the Row consists of the found (blue) word,
followed by two empty cells. In Table 2 the Row consists of the same
found word, followed by two cells which each contain a word related to
it. (The Col.3 cell will sometimes be "empty".) We now need to Copy
the contents of Table2 Cols.2 and 3 into Table1 Cols.2 and 3 (using
their respective "found" Rows). The word in Col.1 of both tables is
left untouched.

"A native speaker of German?" - alas, no, just a life-long amateur.
Though I sometimes browse through the German & French Groups for tips,
I cannot submit questions to them because I use Google as my
Newsreader. Google cannot understand that English speakers might
sometimes want to write in other languages. So they provide no support
for the necessary Umlaut & accented characters. I have not yet found a
better Newsreader guaranteed to work with my line-up of Win XP, Wd2002
and AOL (another american, euro-illiterate organisation). But this is
a VBA site, not politics!

Thank you again for all your efforts. I think we are very close to a
successful outcome. My students will derive much benefit from your
knowledge and skills.

Tschuuuss :-( weil umlautfrei
Robert.

 

[Helmut Weber]

Hi Robert,

with quite some ways of improvement left for your students,
and for you: ;-)

Sub Test411()
' ---
Dim lClr As Long ' color
If InStr(Environ$("Username"), "Weber") > 0 Then
lClr = wdColorYellow
Else
lClr = wdColorBlue
End If
' ---
Dim oTbl(1 To 2) As Table ' array of tables
Dim lRw1 As Long ' counter for rows in table 1
Dim lRw2 As Long ' counter for rows in table 2
Dim lCnt As Long ' just another counter
Dim sTmp As String ' temporary string
Dim rWr1 As Range ' range of a word in table 1
Dim rWr2 As Range ' range of a word in table 2
Dim sEoC As String ' end of cell mark

Set oTbl(1) = ActiveDocument.Tables(1)
Set oTbl(2) = ActiveDocument.Tables(2)
sEoC = Chr(13) & Chr(7)

For lRw1 = 2 To oTbl(1).Rows.Count
Set rWr1 = oTbl(1).Rows(lRw1).Cells(1).Range.Words(1)
If rWr1 <> sEoC Then
If rWr1.Font.Shading.BackgroundPatternColor = lClr Then
rWr1.Select ' testing
For lRw2 = 1 To oTbl(2).Rows.Count
Set rWr2 = oTbl(2).Rows(lRw2).Cells(1).Range.Words(1)
If rWr1 = rWr2 Then
rWr2.Select ' testing
For lCnt = 2 To 3
sTmp = oTbl(2).Cell(lRw2, lCnt).Range.Text
sTmp = Left(sTmp, Len(sTmp) - 2)
' cut off end of cell mark
oTbl(1).Cell(lRw1, lCnt).Range.Text = sTmp
Next
End If
Next
End If
End If
Next
End Sub

Beware of linebreaks by the newsreader!

The drawbacks are:
1st, Words definition of a word
2nd, the assumption, that for each word in column1 of table 1
there isn't more than one match in column1 of table 2!!!
3rd, I switched form the concept of words to string
in the middle of the code without reason.
Have your students correct it. LoL

My philosophy in programming is:
First, show your solution,
then, ask whether anybody can proof that you are wrong,
if not so, there is a solution!
Or you got lazy students.
Then turn to optimization.

Schoenen Tag noch.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Robert]

Dear Helmut,
Thanks a million for this hugely interesting macro. I have just
finished testing it with new data and it has passed with "flying
colours". It copes with the "match" as well as the "no match"
situation, and with the transfer of either one or two words from
Table2, the table of homonyms.

Your "drawback" No.2 would be very unlikely to arise in practice, and I
would be alerted to it from the original document, before running the
macro. My students would be unable to correct your code (if such were
ever needed - unlikely) because they are Third World students of
English, not IT.

I approve totally of your programming philosophy and I remain amazed
that there still exist patient, dedicated people like you ready to give
generously of their time to help others.

It would be easier for a chimpanzee to write Goethe's "Faust" than for
me to write a macro with three nested For --Next loops and assorted If
-- Then conditions. I know my limitations and when I must turn to the
Groups. I am almost never disappointed. And certainly not today.

Thank you once again.
Mit besten Gruessen aus England.
Robert.