Solved: Adding Bookmarks and Sorting

[fredlo2010]

Hello,

I have this document with a couple of tables and I want to rearrange the way they appear on the document.

I want to search for blank cells for the first data set and assign bookmarks to each table with a 1 increment. This will generate odd bookmarks for the type of tables.

so it will be :

Table1
Table3
Table5
Table7

For the next tables I want to search for "Units" and add even numbers, so:

Table2
Table4
Table6

Then I want to sort them :

Table1
Table2
Table3
Table4
Table5
Table6
Table7

Maybe this is not the best way to approach the problem.

I am open to ideas. I have attached a file with the document. If It is too much I understand I just wanna hear some ideas.

Thanks

http://dl.dropbox.com/u/30987064/Document.docx

Here is an image for the final output

http://i45.tinypic.com/etfpm0.jpg

[Frosty]

There is a danger in starting with a solution and then trying to make that solution work. I think you're right in your instinct that this isn't the best way to approach the problem. I would back away from the bookmarks idea and focus on clearly defining the problem you are trying to solve:

1. You have tables in a document which you want to reorganize
2. What is the criteria by which you wish to reorganize these tables? Thus far I have...
a. tables with the first cell blank are a table type of "A"
b. tables which contain the text "Units" are table type of "B"
c. You want to re-organize the tables from the order in which you first find them, to an alternative order of Table type A, followed by Table type B... so that a document which has:

Table 1 (type A)
Table 2 (type A)
Table 3 (type B)
Table 4 (type A)
Table 5 (type A)
Table 6 (type B)
Table 7 (type B)

Would be reorganized to show...
Table 1 (type A)
Table 3 (type B
Table 2 (type A)
Table 6 (type B)
Table 4 (type A)
Table 7 (type B)
Table 5 (type A)

I know this is exactly how you described it, but the approach I'm thinking would handle the above scenario as well as yours.

[fredlo2010]

Thanks for the reply.

there is a part I think its not clear.

The original order would be

Table 1 (type A1)
Table 2 (type A2)
Table 3 (type A3)
Table 4 (type A4)

Table 5 (type B1)
Table 6 (type B2)
Table 7 (type B3)
Table 8 (type B4)

Would be reorganized:

Table 1 (type A1)
Table 2 (type B1)

Table 3 (type A2)
Table 4 (type B2)

Table 5 (type A3)
Table 6 (type B3)

Table 7 (type A4)
Table 8 (type B4)

[Frosty]

That makes sense. Now, would you attach a document sample (no sensitive data please!) which contains tables of both types as well as some (if appropriate) dummy text of the sort which would already be in the document?

I see your image attachments, but would prefer an actual document because there may be more info than what you are actually describing which would help correctly identify the two table types and thus correctly give you a "re-organized" document.

And one additional question: do you want the "re-organized" document to be a new document, or do you want to modify the existing document? Either one is easy, but it can be dangerous to modify existing data... so it is in general better practice to give a new document as the result, verify the result, and then (if necessary) paste that back into the original document manually if you like what you get.

EDIT: nevermind, I see the dropbox link you provided. Just an answer to my one additional question is needed at this point, then I should be able to give you a bit of code to accomplish what you want.

[Frosty]

Here is code which should do what you want it to do, and has a structure which you can adjust as needed. Conceptually it's broken into 3 parts:
1. Main routine for reorganizing your tables
2. A function to identify the table type
3. A function returns a collection tables of the specified type.

There are some clunky parts which could be more elegant... namely, inserting the table from the collection. I've left those a bit more readable so you can maybe more easily adjust them yourself.

And there are some parts which could be expanded upon (namely, how you identify a table... this is the most critical piece, so when/if you find things breaking down, this is the area to look at). Right now, all it does is check the text of the first cell of the table, and if it's blank-- that's a "heading table" and if the all caps version of that text is "UNITS" (it's generally good to ignore case when checking text), then that's a data table. Anything else will be an "unknown" table...

Add this code to the top of a module, or create a new module and copy it all. Let us know how it goes.


Option Explicit

Public Enum MyTableTypes
ttHeading
ttData
ttUnknown
End Enum

' Main function for reorganizing tables

Public Sub ReorganizeTables()
Dim oDoc As Document
Dim oNewDoc As Document
Dim colHeadingTables As Collection
Dim colDataTables As Collection
Dim i As Integer
Dim iCount As Integer
Dim rngWhere As Range
On Error GoTo l_err
' get our data
Set oDoc = ActiveDocument
Set colHeadingTables = fGetTables(oDoc, ttHeading)
Set colDataTables = fGetTables(oDoc, ttData)
' check the counts
iCount = colHeadingTables.Count
If iCount <> colDataTables.Count Then
MsgBox "You do not have the same number of Heading tables as Data tables." & vbCr & _
"Proceeding anyway...", vbInformation, "Check results!"
If iCount < colDataTables.Count Then
iCount = colDataTables.Count
End If
End If
' create a new document
Set oNewDoc = Documents.Add
Set rngWhere = oNewDoc.Range
rngWhere.Collapse wdCollapseStart.
' cycle through the collection with the most number of tables
For i = 1 To iCount
On Error Resume Next
colHeadingTables(i).Range.Copy
' this item doesn't exist, so skip inserting
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr
rngWhere.Collapse wdCollapseEnd
End If
On Error Resume Next
colDataTables(i).Range.Copy
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr & vbCr
rngWhere.Collapse wdCollapseEnd
End If
Next
' Stop
' oNewDoc.Saved = True
' oNewDoc.Close
l_exit:
Exit Sub
l_err:
MsgBox Err.Number & vbCr & Err.Description & vbCr & _
"Better ask VBAExpress what's going on!", vbCritical, "Error!"
Resume l_exit
End Sub

'Primary tester for the type of table -- this may need to become more robust if the table criteria changes

Public Function fGetTableType(oTable As Table) As MyTableTypes
Dim sCellText As String
Dim lRet As MyTableTypes
On Error GoTo l_err
' initialize unknown return
lRet = ttUnknown
With oTable
' get the text of the first cell in the table
sCellText = .Range.Cells(1).Range.text
' remove the end of cell marker
sCellText = Replace(sCellText, Chr(13) & Chr(7), "")
' check the content to determine the type
If sCellText = "" Then
lRet = ttHeading
ElseIf VBA.UCase(sCellText) = "UNITS" Then
lRet = ttData
End If
End With
l_exit:
fGetTableType = lRet
Exit Function
l_err:
lRet = ttUnknown
Resume l_exit
End Function

' return a collection of appropriate table types in the passed document

Public Function fGetTables(oDoc As Document, lReturnWhatType As MyTableTypes) As Collection
Dim colRet As Collection
Dim oTable As Table
On Error GoTo l_err
' create a new instance
Set colRet = New Collection
For Each oTable In oDoc.Tables
' only add the appropriate types to our collection
If fGetTableType(oTable) = lReturnWhatType Then
colRet.Add oTable
End If
Next
Set fGetTables = colRet
l_exit:
Exit Function
l_err:
Set fGetTables = Nothing
Resume l_exit
End Function

[fredlo2010]

Man this works perfectly, well not perfectly but i can work with what i got.

The part where it copies to a new document does not matter. I get the data from a program and then paste it in a word document. There is no way of spoiling data or a master document or anything like that. But there is data before and after the tables so maybe its better not to mess with it. I have no idea how you did it but a solution would be to start pasting the tables after the last text string of the last paragraph before all the tables (the first line break in the whole document, is the only identifier i can see, and a bookmark)

The other little issue I have is that the table on the second document has a higher indentation. I can go to the original document and
past the sorted data back and the everything is fine. This makes me think that maybe the sorting in the document and not a new one is better.

Thank you so much for your help.

:)

[Frosty]

It may help if you (again, no sensitive data, please), attach a "before" document (which you would run the *mostly* working code on) and the "after" document (which is the document after you've pasted the re-organized tables in).

It would be easy enough to adjust the code to either:

a. Insert copies of the re-organized tables into the current document wherever your cursor is, and then delete the original tables from the current document.

b. Do the same as a. but insert the re-organized tables at a specific bookmark (but you'd need to specify the bookmark).

However, the image above shows me a lot of bookmarks in the document... you should know that bookmarks are unique to a document (you can only have 1 bookmark in a document named "hello").

If you copy text (including tables) which contains the bookmark "hello" and paste it into a new document-- that "hello" bookmark will come along with it.

If you paste that same text into the same document... the "hello" bookmark will *only* be in the place where you pasted... it will be removed from the text which you copied.

So I'm hesitant to muck with your bookmarks too much...

See if you can post a before and after document, and I may be able to improve the code a bit with minimal effort.

[Frosty]

As a quick example... here's an updated version of the ReorganizeTables routine which puts copies of the tables re-organized at wherever your cursor is. Then it deletes the original tables (although it will probably leave a lot of empty text behind, something which could be easily addressed if I understood your documents a bit better).


' Main function for reorganizing tables

Public Sub ReorganizeTables()
Dim oDoc As Document
Dim oNewDoc As Document
Dim colHeadingTables As Collection
Dim colDataTables As Collection
Dim i As Integer
Dim iCount As Integer
Dim rngWhere As Range
On Error GoTo l_err
' get our data
Set oDoc = ActiveDocument
Set colHeadingTables = fGetTables(oDoc, ttHeading)
Set colDataTables = fGetTables(oDoc, ttData)
' check the counts
iCount = colHeadingTables.Count
If iCount <> colDataTables.Count Then
MsgBox "You do not have the same number of Heading tables as Data tables." & vbCr & _
"Proceeding anyway...", vbInformation, "Check results!"
If iCount < colDataTables.Count Then
iCount = colDataTables.Count
End If
End If
' create a new document
' Set oNewDoc = Documents.Add
' Set rngWhere = oNewDoc.Range
Set rngWhere = Selection.Range
rngWhere.Collapse wdCollapseStart
' cycle through the collection with the most number of tables
For i = 1 To iCount
On Error Resume Next
colHeadingTables(i).Range.Copy
' this item doesn't exist, so skip inserting
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr
rngWhere.Collapse wdCollapseEnd
End If
On Error Resume Next
colDataTables(i).Range.Copy
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr & vbCr
rngWhere.Collapse wdCollapseEnd
End If
Next
' delete the original tables
For i = iCount To 1 Step -1
On Error Resume Next
colHeadingTables(i).Delete
colDataTables(i).Delete
Next
' Stop
' oNewDoc.Saved = True
' oNewDoc.Close
l_exit:
Exit Sub
l_err:
MsgBox Err.Number & vbCr & Err.Description & vbCr & _
"Better ask VBAExpress what's going on!", vbCritical, "Error!"
Resume l_exit
End Sub

[Frosty]

Additional question-- are the tables you are re-organizing contiguous (i.e., after running the macro, can you delete EVERYTHING between the start of the first table and the end of the last table)?

If so, that's really easy to handle and may solve the problem of the extra space left over from just deleting tables, and not the blank lines between them, since you could just put your cursor immediately able where the tables start, and that's where you'll paste in the re-organized tables, and then delete everything from there to the end of the "tables" area.

[Frosty]

As an example, with the following modification to the code, you could easily put your cursor in a blank paragraph above your first table, add the following code to the area in the above "update" to handle better deleting the tables... ASSUMING they are contiguous the way they were in your sample document.



' delete the original tables
' For i = iCount To 1 Step -1
' On Error Resume Next
' colHeadingTables(i).Delete
' colDataTables(i).Delete
' Next
' redefine the start of our range
Set rngWhere.Start = colHeadingTables(1).Range.Start
' see if the first data table is earlier
If colDataTables(1).Range.Start < rngWhere.Start Then
rngWhere.Start = colDataTables(1).Range.Start
End If
' and the end of our range
rngWhere.End = colDataTables(colDataTables.Count).Range.End
If colHeadingTables(colHeadingTables.Count).Range.End > rngWhere.End Then
rngWhere.End = colHeadingTables(colHeadingTables.Count).Range.End
End If
rngWhere.Delete


(sorry to give it to you in piece meal, but I think replacing chunks of code will help you learn, and it will also make the thread easier to read).

[fumei]

Man you are fast Jason. I get on today and see the thread, figuring it is going to be the start. But no. You have already come up with something.

[Frosty]

Well, it's always easy to come up with "something" ... but is it THE thing? ... that's harder ;)

[fredlo2010]

Hello,

OK guys thank you so much for all the help and feedback. Frosty I am a little confused now after your last comments. I have attached a copy of the document so you guys can look at it and how it looked at the beginning and what I am aiming for.

Whats missing from the document


1. I need to fix an issue when I have a Sale. It is explained in details withing the text. Its the huge comment block.

2. The sorting table thing

3. Get rid of the bar-code characters in the footer *1(&*(*%%&%#$%$#$^%

4. Maybe some housekeeping.




Sub Proposal_Editor()

Dim sText As String
Dim bmRange As Range

Application.ScreenUpdating = True

'DELETE ALL SUBTOTAL LINES

sText = "Subtotal"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete

End If
Loop

'DELETE PORTES

sText = "Ports:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
Selection.Delete

Loop

'DELETE PORTES PRICE AXAPTA TABLE

sText = "Unit price. truck:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time crane:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time standby:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

'DELETE SUBFAMILY TABLE

sText = "SUMMARY BY SUBFAMILIES"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

'DELETE ALL RESUMEN SUBFAMILY

Selection.GoTo What:=wdGoToBookmark, Name:="RESUMENSUBFAMILIAS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.Tables(1).Delete

'DELETE HEADER ARTICLE SUMMARY

Selection.GoTo What:=wdGoToBookmark, Name:="TITLEARTICULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.Tables(1).Delete


'ALIGN TABLES TO THE LEFT

Selection.GoTo What:=wdGoToBookmark, Name:="RESUMENARTICULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft


'DELETE ALL INNER TOTAL SUBHEADERS

sText = "Total-"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop


'FORMART THE APPENDIX TOTALS

Selection.GoTo What:=wdGoToBookmark, Name:="CAPITULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Options.DefaultBorderLineWidth = wdLineWidth100pt
Options.DefaultBorderColor = -721387265
Selection.Shading.Texture = wdTextureNone
Selection.Shading.BackgroundPatternColor = -721354957
Selection.Shading.BackgroundPatternColor = 15527160
Selection.Font.Name = "Times New Roman"
Selection.Font.Size = 12
Selection.Font.Color = -721387265



'FORMAT GENERAL CONDITIONS OF THE CONTRACT

' Specify search phrases (start / end)
a$ = "GENERAL EQUIPMENT LEASE CONDITIONS "
B$ = "LESSEE SIGNATURE AND COMPANY STAMP "

' Start at the beginning and reset all
' search formatting options

ActiveDocument.Range(0).Select
Selection.Find.ClearFormatting
' Loop repeats until first phrase not found
While Selection.Find.Execute(a$)
StartReformat = Selection.End
Selection.MoveRight
Selection.Find.Execute (B$)
StopReformat = Selection.Start
Selection.MoveRight
' Add formatting to the following section
' Options include:
' .Bold, .Italic, .Underline, .StrikeThrough (true / false)
' .Size = font size
' .Font.Color = wdColorGreen (Red, Blue, etc... see help)

With ActiveDocument.Range(StartReformat, StopReformat)
.Font.Size = 6.5

End With
Wend



'FORMAT BOLT THE JOBSITE

' Specify search phrases (start / end)
a$ = "Lease/Sale of our equipment for your project "
B$ = " in "

' Start at the beginning and reset all
' search formatting options

ActiveDocument.Range(0).Select
Selection.Find.ClearFormatting
' Loop repeats until first phrase not found
While Selection.Find.Execute(a$)
StartReformat = Selection.End
Selection.MoveRight
Selection.Find.Execute (B$)
StopReformat = Selection.Start7960
' .Font.Color = wdColorGreen (Red, Blue, etc... see help)

With ActiveDocument.Range(StartReformat, StopReformat)
.Font.Bold = wdToggle

End With
Wend



'REPLACE ALL USD FOR $

CommandBars("Navigation").Visible = False
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "USD"
.Replacement.Text = "$ "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll



'ADD TEXT TO ALL THE HEADERS WITH THE WORD "UNITS" AND "DESCRIPTION"

Dim r As Range
Set r = ActiveDocument.Range
With r.Find
Do While .Execute(findtext:="List Price", Forward:=True) = True
If r.Information(wdWithInTable) Then
With r
.Rows(1).Cells(1).Range.Text = "Units"
.Rows(1).Cells(2).Range.Text = "Description"
.Collapse 0
End With
End If
Loop
End With




'CLEANINGUP THE "UNITS" AND DESCRIPTION" FROM THE SALES HEADER

'this is commented out because i dont know how to make it work but its supposed
'to find the word "Sale" in all tables and then delete the contents from cell 1 and cell 2,
'this is an exception to the code previously used. You will notice the error because when you try




'Set r = ActiveDocument.Range
'With r.Find
' Do While .Execute(findtext:="Sale", Forward:=True) = True
' If r.Information(wdWithInTable) Then
' With r
' .Rows(1).Cells(1).Range.Text = ""
' .Rows(1).Cells(2).Range.Text = ""
' .Collapse 0
' End With
' End If
' Loop
'End With



'SPLIT ALL THE TABLES WITH A STRING "List Price" AND "Total amount"

Dim Tbl As Table
Dim RngFnd As Range
Dim StrFindTxt As String

'First Part

StrFindTxt = "List Price"

For Each Tbl In ActiveDocument.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = StrFindTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
With RngFnd.Duplicate

'The next two lines break the table *after* the found row
'If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
'.Tables(1).Split .Cells(1).RowIndex + 1
'The next two lines break the table *before* the found row

If .Cells(1).RowIndex > 1 Then
.Tables(1).Split .Cells(1).RowIndex
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing

'Second Part

StrFindTxt = "Total amount"


For Each Tbl In ActiveDocument.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = StrFindTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
With RngFnd.Duplicate

'The next two lines break the table *after* the found row
'If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
'.Tables(1).Split .Cells(1).RowIndex + 1
'The next two lines break the table *before* the found row

If .Cells(1).RowIndex > 1 Then
.Tables(1).Split .Cells(1).RowIndex
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing



'DELETE ALL EMPTY ROWS IN ALL TABLES

Dim oTable As Table, oRow As Range, oCell As Cell, Counter As Long, _
NumRows As Long, TextInRow As Boolean


For Each oTable In ActiveDocument.Tables 'Specify which table you want to work on.

'Set oTable = Selection.Tables(1)
' Set a range variable to the first row's range
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.Count

For Counter = 1 To NumRows

StatusBar = "Row " & Counter
TextInRow = False

For Each oCell In oRow.Rows(1).Cells
If Len(oCell.Range.Text) > 2 Then 'end of cell marker is actually 2 characters
TextInRow = True
Exit For
End If
Next oCell

If TextInRow Then
Set oRow = oRow.Next(wdRow)
Else
oRow.Rows(1).Delete
End If

Next Counter
Next oTable

Application.ScreenUpdating = True

End Sub




Thanks again

PS: I already ordered my Word VBA book. I hope I have better luck with this one.


Here is the link for the document.

http://dl.dropbox.com/u/30987064/Original.docm
:)

[Frosty]

Oh boy... I clearly haven't followed all of the relevant threads.

I don't see an attachment document, just your code. If you've already posted the before/after in another thread, I can probably find it, but would appreciate the link if you have it handy.

Other that, my only comment at the moment is that there is a little bit of modularization to be done on that enormous subroutine. You have, however, commented it very well.

[fredlo2010]

Oh boy... I clearly haven't followed all of the relevant threads.

I don't see an attachment document, just your code. If you've already posted the before/after in another thread, I can probably find it, but would appreciate the link if you have it handy.

Other that, my only comment at the moment is that there is a little bit of modularization to be done on that enormous subroutine. You have, however, commented it very well.


Here I updated the link to the document. I trust Dropbox a little better.

http://dl.dropbox.com/u/30987064/Original.docm

I know its a long macro, The thing is that i have it set to run and perform all the changes to the document with the click of a button. Oh that's maybe why my screen flickers and blinks even with screenupdating off. (i know that the sample says on, it was something i was working on this morning and i forgot to change back)

The example is a medium size document. I gotta do several of those everyday :)

[fumei]

Frosty, the original thread is titled: Search for string in table loops forever

[Frosty]

Fred,

The amount of processing that happens when you do a single click isn't a concern. The length of that macro makes it very hard to troubleshoot individual bits which may not be working.

As an analogy... you've written a 300 page book with only 1 chapter.

If you organize your code (book) into multiple subroutines (chapters), it will serve you well in troubleshooting elements. I'd imagine that the books Gerry/Fumei recommended will cover that topic extensively. For now, I will take a look at what you have and see if I can't help a bit without rewriting the whole thing for you ;)

[Frosty]

Fred,

Just to cover the bases... can you do the following:

1. Run the code on Original.docm.
2. Do the rest of the manual fixes you would do (manually resorting the tables, removing the footer stuff, etc)
3. Put the result as Result.docm (or docx) in your dropbox.

This will allow me to do a redline between the two, and I can use that as a bit of verification.

I want to say you've done an enormous amount of work, and you make it much much easier for us to give you assistance by this work. I actually have to do a bit of money work today, so I may not be able to get back to you with a real solution as fast as I did yesterday, but you're pretty close.

You're going to have learned a lot from this process, I think... and any additional troubleshooting will end up being even easier, at the end of the day. And it will still end up being a one-click "Proposal_Editor" subroutine. Just a bit more organized into constituent parts.

I have two immediate comments, although I don't want it to throw too much of a wrench in your development (and learning) process.

1. You should use Option Explicit at the top of any modules. This will be automatically inserted in new modules if you, in the VBA IDE, go to Tools > Options > Editor Tab and make sure "Require Variable Declaration" is checked. It's also helpful (for me, at least), to uncheck "Auto Syntax Check" in that same dialog.

2. Consistent indenting. This makes your code much more readable. Everyone has a different style and preference, but you won't go terribly wrong by following something along the lines of the indenting the VBA tags on this forum give you (although the way code looks is not my particular style, it is consistent).

And one other note... the reason your screen flickers (despite Application.ScreenUpdating = False) is because of your use of the Selection object. No matter what you do in terms of screen updating, if you use the Selection object, you cause Word to do a refresh. So the more you use the selection object, the less word "obeys" your instruction about screen updating. This isn't a really big deal in terms of whether something works or not, it's simply information for you.

[Frosty]

Fred,

Just a quick explanation for where this is about to go. Our interests do converge (believe me), but everyone does this free "work" on this board for different reasons. My reasons may not be as altruistic as others. The reason I do this is twofold: 1) keeping my own coding skills sharp and 2) continually reenforcing my own ability to organize thoughts and explain those thoughts to others with less of a programming background.

So, I'm going to (hopefully) teach you (and anyone else that reads this thread) some thing about how I code in the process of giving you a product which works the way you want it to (and in addition, is easier to troubleshoot and modify).

It would be shorter for me to simply do it all for you... but I might as well get paid for that. So I take a little bit longer to get to your desired end result so that you and I both benefit. I hope you can understand (and benefit from) my part in this process. Please ask questions when you don't understand something. Rather than being annoying, it actually helps me identify where I can be more clear.

Now, in my best Sean Connery voice... here begineth the lesson. :)

Modularizing your code:
Any time you find yourself copying and pasting chunks of code within a routine, that is your best bit of information that it is a good time to break your code apart into a subroutine. Rather than repeatedly using the same chunk of code to delete rows which contains a certain bit of text, i.e.,

sText = "Subtotal"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Unit price. truck:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time crane:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time standby:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "SUMMARY BY SUBFAMILIES"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Total-"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop
You can more easily modularize your code (and fix things when something is wrong) by creating a subroutine with a parameter... as an example...

'-----------------------------------------------------------------------------------------------
' Delete rows which contain the passed text, if no document passed, works on activedocument
'-----------------------------------------------------------------------------------------------
Public Sub DeleteRowsWith(sThisText As String, Optional oInDoc As Document)
Dim rngSearch As Range

If oInDoc Is Nothing Then
Set oInDoc = ActiveDocument
End If

Set rngSearch = oInDoc.Content

With rngSearch.Find
.ClearFormatting
.Text = sThisText
.Wrap = wdFindContinue
Do While .Execute
If .Found Then
If rngSearch.Information(wdWithInTable) Then
rngSearch.Rows.Delete
End If
End If
Loop
End With
End Sub
And then you can call that routine from within your main routine in the following manner. Note, in the above routine, I have also demonstrated the use of an Optional parameter-- this is a parameter you don't have to pass, but make sure you set it to something if you haven't passed it... while this is not necessary for this project (since you are probably always working on the activedocument), it is not a bad practice.

You can then call this subroutine from your main routine. For example:

Public Sub MainRoutine
DeleteRowsWith "Subtotal"
DeleteRowsWith "Unit price. truck:"
DeleteRowsWith "Price time crane:"
DeleteRowsWith "Price time standby:"
DeleteRowsWith "SUMMARY BY SUBFAMILIES"
DeleteRowsWith "Total-"
End Sub


All for now as I wend my way through your code.

[Frosty]

One additional note... you can easily test your subroutines by using the immediate window. For example, in the VBA IDE, with a sample document open... you could type the following in the Immediate Window (View > Immediate Window or use CTRL+G to display it):

DeleteRowsWith "Subtotal"

Then hit enter, and it should run that routine. Check your document to see how it did.

[fredlo2010]

Frosty,

I am attaching ( via dropbox) pies of the original document and the one after the formatting.

http://dl.dropbox.com/u/30987064/New%20Folder/Original.docx
http://dl.dropbox.com/u/30987064/New%20Folder/Original%20After%20Changes.docx


This is the code I used to get the first part of it; the rest of the formatting I did manually.


Dim sText As String
Dim bmRange As Range

Application.ScreenUpdating = True

'DELETE ALL SUBTOTAL LINES

sText = "Subtotal"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete

End If
Loop

'DELETE PORTES

sText = "Ports:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
Selection.Delete

Loop

'DELETE PORTES PRICE AXAPTA TABLE

sText = "Unit price. truck:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time crane:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

sText = "Price time standby:"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

'DELETE SUBFAMILY TABLE

sText = "SUMMARY BY SUBFAMILIES"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop

'DELETE ALL RESUMEN SUBFAMILY

Selection.GoTo What:=wdGoToBookmark, Name:="RESUMENSUBFAMILIAS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.Tables(1).Delete

'DELETE HEADER ARTICLE SUMMARY

Selection.GoTo What:=wdGoToBookmark, Name:="TITLEARTICULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.Tables(1).Delete


'ALIGN TABLES TO THE LEFT

Selection.GoTo What:=wdGoToBookmark, Name:="RESUMENARTICULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft


'DELETE ALL INNER TOTAL SUBHEADERS

sText = "Total-"
Selection.Find.ClearFormatting
With Selection.Find
.Text = sText
.Wrap = wdFindContinue
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Loop


'FORMART THE APPENDIX TOTALS

Selection.GoTo What:=wdGoToBookmark, Name:="CAPITULOS"
With ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = True
End With
Selection.Tables(1).Select
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Options.DefaultBorderLineWidth = wdLineWidth100pt
Options.DefaultBorderColor = -721387265
Selection.Shading.Texture = wdTextureNone
Selection.Shading.BackgroundPatternColor = -721354957
Selection.Shading.BackgroundPatternColor = 15527160
Selection.Font.Name = "Times New Roman"
Selection.Font.Size = 12
Selection.Font.Color = -721387265



'FORMAT GENERAL CONDITIONS OF THE CONTRACT

' Specify search phrases (start / end)
a$ = "GENERAL EQUIPMENT LEASE CONDITIONS "
B$ = "LESSEE SIGNATURE AND COMPANY STAMP "

' Start at the beginning and reset all
' search formatting options

ActiveDocument.Range(0).Select
Selection.Find.ClearFormatting
' Loop repeats until first phrase not found
While Selection.Find.Execute(a$)
StartReformat = Selection.End
Selection.MoveRight
Selection.Find.Execute (B$)
StopReformat = Selection.Start
Selection.MoveRight
' Add formatting to the following section
' Options include:
' .Bold, .Italic, .Underline, .StrikeThrough (true / false)
' .Size = font size
' .Font.Color = wdColorGreen (Red, Blue, etc... see help)

With ActiveDocument.Range(StartReformat, StopReformat)
.Font.Size = 6.5

End With
Wend



'FORMAT BOLT THE JOBSITE

' Specify search phrases (start / end)
a$ = "Lease/Sale of our equipment for your project "
B$ = " in "

' Start at the beginning and reset all
' search formatting options

ActiveDocument.Range(0).Select
Selection.Find.ClearFormatting
' Loop repeats until first phrase not found
While Selection.Find.Execute(a$)
StartReformat = Selection.End
Selection.MoveRight
Selection.Find.Execute (B$)
StopReformat = Selection.StartOriginal.docm
' .Font.Color = wdColorGreen (Red, Blue, etc... see help)

With ActiveDocument.Range(StartReformat, StopReformat)
.Font.Bold = wdToggle

End With
Wend



'REPLACE ALL USD FOR $

CommandBars("Navigation").Visible = False
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "USD"
.Replacement.Text = "$ "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll



'ADD TEXT TO ALL THE HEADERS WITH THE WORD "UNITS" AND "DESCRIPTION"

Dim r As Range
Set r = ActiveDocument.Range
With r.Find
Do While .Execute(findtext:="List Price", Forward:=True) = True
If r.Information(wdWithInTable) Then
With r
.Rows(1).Cells(1).Range.Text = "Units"
.Rows(1).Cells(2).Range.Text = "Description"
.Collapse 0
End With
End If
Loop
End With




'CLEANINGUP THE "UNITS" AND DESCRIPTION" FROM THE SALES HEADER

'this is commented out because i dont know how to make it work but its supposed
'to find the word "Sale" in all tables and then delete the contents from cell 1 and cell 2,
'this is an exception to the code previously used. You will notice the error because when you try




'Set r = ActiveDocument.Range
'With r.Find
' Do While .Execute(findtext:="Sale", Forward:=True) = True
' If r.Information(wdWithInTable) Then
' With r
' .Rows(1).Cells(1).Range.Text = ""
' .Rows(1).Cells(2).Range.Text = ""
' .Collapse 0
' End With
' End If
' Loop
'End With



'SPLIT ALL THE TABLES WITH A STRING "List Price" AND "Total amount"

Dim Tbl As Table
Dim RngFnd As Range
Dim StrFindTxt As String

'First Part

StrFindTxt = "List Price"

For Each Tbl In ActiveDocument.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = StrFindTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
With RngFnd.Duplicate

'The next two lines break the table *after* the found row
'If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
'.Tables(1).Split .Cells(1).RowIndex + 1
'The next two lines break the table *before* the found row

If .Cells(1).RowIndex > 1 Then
.Tables(1).Split .Cells(1).RowIndex
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing

'Second Part

StrFindTxt = "Total amount"


For Each Tbl In ActiveDocument.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = StrFindTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
With RngFnd.Duplicate

'The next two lines break the table *after* the found row
'If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
'.Tables(1).Split .Cells(1).RowIndex + 1
'The next two lines break the table *before* the found row

If .Cells(1).RowIndex > 1 Then
.Tables(1).Split .Cells(1).RowIndex
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing



'DELETE ALL EMPTY ROWS IN ALL TABLES

Dim oTable As Table, oRow As Range, oCell As Cell, Counter As Long, _
NumRows As Long, TextInRow As Boolean


For Each oTable In ActiveDocument.Tables 'Specify which table you want to work on.

'Set oTable = Selection.Tables(1)
' Set a range variable to the first row's range
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.Count

For Counter = 1 To NumRows

StatusBar = "Row " & Counter
TextInRow = False

For Each oCell In oRow.Rows(1).Cells
If Len(oCell.Range.Text) > 2 Then 'end of cell marker is actually 2 characters
TextInRow = True
Exit For
End If
Next oCell

If TextInRow Then
Set oRow = oRow.Next(wdRow)
Else
oRow.Rows(1).Delete
End If

Next Counter
Next oTable

Application.ScreenUpdating = True

End Sub



1. Thanks for the tip on variables. The thing is that my code is made out of a lot of things: web forums, macros recordings, and the little I write myself. But yes, defining consistent variables and using different modules to separate subroutines will make my code a lot more readable and malleable. The option has been turned on.

2. I try to keep indentation as clean as possible. In some parts of the code you will see a drastic change. This is was done on purpose to make it pop up even more.

Yeah it will be hard for me to get rid of the section option or at least I will try to minimize its use as much as I can. But again most of this comes from my inexperience. I see there is a bookmark for a table that I want to delete. I go to the bookmark I select the table there and delete.

It will be great to learn new things. By the way I just got my new Macros 2010 book. I am on Chapter 6 already and for instance I learned that I can use the buttons from a MsgBox to control macros. I was thinking about this the long way around creating a Form and then assigning codes to buttons. I am implementing this for an item I wanna delete but the user might choose not to. (this is not included in the code, its fairy easy so I already have it)


Thanks so much for your help and feedback. Don't worry about time; we all have to work and go to school ( at least I do)

[Frosty]

Next lesson -- using a function to return something.

You have some *almost* repeated code, which basically identifies a table by the same methodology (whatever the table is that contains a specific bookmark), but you do different things with the table you identify: delete it, align the text within it left, adjust some borders. Here is way to modularize some of that code without sacrificing the flexibility of what to do with the identified table (I won't bother posting the original code this time).

The function to return the identified table:

'-----------------------------------------------------------------------------------------------
' Return a table containing a bookmark
'-----------------------------------------------------------------------------------------------
Public Function fGetTableContaining(sBookmarkName As String, _
Optional oInDoc As Document) As Table
Dim rngWhere As Range

If oInDoc Is Nothing Then
Set oInDoc = ActiveDocument
End If
Set rngWhere = oInDoc.Bookmarks(sBookmarkName).Range
If Not rngWhere Is Nothing Then
If rngWhere.Information(wdWithInTable) Then
Set fGetTableContaining = rngWhere.Tables(1)
End If
End If
End Function
And a demonstration of how you would use it in your various ways in the "Main routine"

Public Sub MainRoutine
'DELETE ALL RESUMEN SUBFAMILY
fGetTableContaining("RESUMENSUBFAMILIAS").Delete

'DELETE HEADER ARTICLE SUMMARY
fGetTableContaining("TITLEARTICULOS").Delete

'ALIGN TABLES TO THE LEFT
fGetTableContaining("RESUMENARTICULOS").Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

'FORMART THE APPENDIX TOTALS
'FROSTY NOTE: I'm not sure these two application settings are necessary
'they may be left overs from the recorded macro
Options.DefaultBorderLineWidth = wdLineWidth100pt
Options.DefaultBorderColor = -721387265
'with this table
With fGetTableContaining("CAPITULOS").Range
With .Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Shading
.Texture = wdTextureNone
.BackgroundPatternColor = -721354957
.BackgroundPatternColor = 15527160
End With
With .Font
.Name = "Times New Roman"
.Size = 12
.Color = -721387265
End With
End With

End Sub

[Frosty]

Fred,

No worries-- it's obvious that you code comes from multiple sources. It's commendable that you've gotten as far as you have. And it is a pleasure to teach someone willing to learn.

Thanks for the attachments.

All for now.

[fredlo2010]

Frosty,

I started implementing the code you have helped me with. I understand what you are doing. Although it is hard to get. I see clearly the use of the functions ( I have used some small functions before in Excel)

I will be waiting for more.

Thanks

[fredlo2010]

Frosty,

Thanks to your help I was able to create a piece of code that will open a specific document when pressing a button in a form and then copy the text from that document and paste it.

I use a general sub with a variable that will change according to the file name that's supposed to be opened.

Of course it might not be the best. But its an improvement. I was trying to use the document Content feature but I could not place the cursor back in the original document. I had to stick to Selection, but its ok I will get better.

Here is the code I used for the main sub



Public Sub Open_Description_Documents(varDoc As String)

Dim varRange As range

Documents.Open FileName:=varDoc

Selection.WholeStory
Selection.Copy
ActiveWindow.Close
Selection.PasteAndFormat (wdFormatOriginalFormatting)

End Sub


The code for one of the buttons



Private Sub CommandButton1_Click()

UserForm1.Hide

Open_Description_Documents "C:\Users\Alfredo\Dropbox\Macros for work\Sub Proposal.docx"


End Sub

[fredlo2010]

Frosty,

Thanks to your help I was able to create a piece of code that will open a specific document when pressing a button in a form and then copy the text from that document and paste it.

I use a general sub with a variable that will change according to the file name that's supposed to be opened.

Of course it might not be the best. But its an improvement. I was trying to use the document Content feature but I could not place the cursor back in the original document. I had to stick to Selection, but its ok I will get better.

Here is the code I used for the main sub



Public Sub Open_Description_Documents(varDoc As String)

Dim varRange As range

Documents.Open FileName:=varDoc

Selection.WholeStory
Selection.Copy
ActiveWindow.Close
Selection.PasteAndFormat (wdFormatOriginalFormatting)

End Sub


The code for one of the buttons



Private Sub CommandButton1_Click()

UserForm1.Hide

Open_Description_Documents "C:\Users\Alfredo\Dropbox\Macros for work\Sub Proposal.docx"


End Sub

Ok I cannot get it to work. The only way of making it work is to have more than one Word document open.

This should be an issue with my active windows thing. I need to work on it.

:( i thought I had it

[fredlo2010]

OK,

I have been playing with the code for the descriptions and it gives me an error when I open a new document and don't type anything as soon as I type a single character then the code runs fine.

The error message is

http://i50.tinypic.com/2mcat61.jpg

So strange :think:

[Frosty]

Sorry Fred, can only address one thing at a time. I'm still working on your original code.

It looks to me like you original document has a data problem, which is why your attempt to look for table cells which contain "Sale" and then clear out the two cells is causing you a problem.

Here is a revisit of your original code (as well as my reorganize code). I've posted the code as well as attached the document I was working on. As you'll see, it's not quite right... but the code should work if your data is "correct."

NOTE: you *ARE* going to get an error running the code on the attachment. But this is because your data is wrong. If you get the right data, I suspect it will start working.

Let me know how it goes, but I would work on this piece before moving to others. It will be a lot easier that way. Well, easier for me anyway :)

I think you should be able to see your code in these adjustments (I have in large part not addressed any methodology)... just refined so you can talk about specific pieces which don't work. I'm posting the code so others can comment and help without needing to download the attachment.

What will be helpful to you in this approach is to use the immediate window and try out the various procedures on your document, so you can troubleshoot those specific procedures, rather than continually running all of the code up to a certain point, and then trying to troubleshoot that point. You could, for example, try out the new "DeleteRowsWith" procedure by
1. CTRL + G (to show the immediate window)
2. Type: DeleteRowsWith "SubTotal"
3. Press Enter.
4. Check out your document.

Option Explicit
Public Enum MyTableTypes
ttHeading
ttData
ttUnknown
End Enum
'-----------------------------------------------------------------------------------------------
' Main Routine
'-----------------------------------------------------------------------------------------------
Public Sub Proposal_Editor()

Dim sText As String
Dim bmRange As Range

Application.ScreenUpdating = True

'FROSTY NOTE: some additions here
DeleteCellTextContaining sBookmarkName:="Barcode"

'DELETE ALL SUBTOTAL LINES
DeleteRowsWith "Subtotal"

'DELETE PORTES
'FROSTY NOTE: Named arguments and a simple execute statement is a little simpler
' also doesn't use the selection object
' and is simple enough not to require a separate sub-routine
ActiveDocument.Content.Find.Execute findtext:="Ports:", _
ReplaceWith:="", _
Replace:=wdReplaceAll


'DELETE PORTES PRICE AXAPTA TABLE
DeleteRowsWith "Unit price. truck:"
DeleteRowsWith "Price time crane:"
DeleteRowsWith "Price time standby:"

'DELETE SUBFAMILY TABLE
DeleteRowsWith "SUMMARY BY SUBFAMILIES"

'DELETE ALL RESUMEN SUBFAMILY
fGetTableContaining("RESUMENSUBFAMILIAS").Delete

'DELETE HEADER ARTICLE SUMMARY
fGetTableContaining("TITLEARTICULOS").Delete

'ALIGN TABLES TO THE LEFT
fGetTableContaining("RESUMENARTICULOS").Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

'DELETE ALL INNER TOTAL SUBHEADERS
DeleteRowsWith "Total-"


'FORMART THE APPENDIX TOTALS
'FROSTY NOTE: I'm not sure these two application settings are necessary
'they may be left overs from the recorded macro
Options.DefaultBorderLineWidth = wdLineWidth100pt
Options.DefaultBorderColor = -721387265
'with this table
With fGetTableContaining("CAPITULOS").Range
With .Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With .Shading
.Texture = wdTextureNone
.BackgroundPatternColor = -721354957
.BackgroundPatternColor = 15527160
End With
With .Font
.Name = "Times New Roman"
.Size = 12
.Color = -721387265
End With
End With

'FORMAT GENERAL CONDITIONS OF THE CONTRACT
With fGetRangeBetween("GENERAL EQUIPMENT LEASE CONDITIONS", _
"LESSEE SIGNATURE AND COMPANY STAMP")
' Add formatting to the following section
' Options include:
' .Bold, .Italic, .Underline, .StrikeThrough (true / false)
' .Size = font size
' .Font.Color = wdColorGreen (Red, Blue, etc... see help)
.Font.Size = 6.5
End With

'FORMAT BOLT THE JOBSITE

With fGetRangeBetween("Lease/Sale of our material for your project ", _
" in ")
'FROSTY NOTE: probably better to specify the value, rather than use the Toggle
'.Font.Bold = wdToggle
.Font.Bold = True
End With

'REPLACE ALL USD FOR $
'FROSTY NOTE: is this necessary?
CommandBars("Navigation").Visible = False

'simple find/replaceall, doesn't have to use selection object
ActiveDocument.Content.Find.Execute findtext:="USD", _
ReplaceWith:="$ ", _
Replace:=wdReplaceAll, _
MatchCase:=False, _
Format:=False, _
MatchWholeWord:=False, _
MatchWildcards:=False, _
MatchSoundsLike:=False, _
MatchAllWordForms:=False


'ADD TEXT TO ALL THE HEADERS WITH THE WORD "UNITS" AND "DESCRIPTION"
AdjustTableCells "List Price", "Units", "Description"

'CLEANINGUP THE "UNITS" AND DESCRIPTION" FROM THE SALES HEADER
AdjustTableCells "Sale", "", ""

'SPLIT ALL THE TABLES WITH A STRING "List Price" AND "Total amount"
'First Part
SplitSomeTables "List Price"

'Second Part
SplitSomeTables "Total Amount"

'DELETE ALL EMPTY ROWS IN ALL TABLES
DeleteEmptyRows

'FROSTY NOTE: here is the addition of reformatting the tables using the code previously posted
ReorganizeTables ActiveDocument.Bookmarks("FOTO").Range.Paragraphs(1).Previous.Range

Application.ScreenUpdating = True

End Sub
'-----------------------------------------------------------------------------------------------
' Pass in find text and replace text-- and replaces cells 1 and 2, if the text is found in a table
'-----------------------------------------------------------------------------------------------
Public Sub AdjustTableCells(sFindText As String, sCell1Text As String, sCell2Text As String, _
Optional oDoc As Document)
Dim r As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
Set r = oDoc.Range
With r.Find
Do While .Execute(findtext:=sFindText, Forward:=True) = True
If r.Information(wdWithInTable) Then
With r
.Rows(1).Cells(1).Range.Text = sCell1Text
.Rows(1).Cells(2).Range.Text = sCell2Text
.Collapse 0
End With
End If
Loop
End With
End Sub
'-----------------------------------------------------------------------------------------------
'Return a range between the passed text
'-----------------------------------------------------------------------------------------------
Public Function fGetRangeBetween(sStartText As String, _
sEndText As String, _
Optional oDoc As Document) As Range
Dim StartReformat As Long
Dim StopReformat As Long
Dim rngSearch As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If

Set rngSearch = oDoc.Content
With rngSearch.Find
.ClearFormatting
'this returns true if the start text is found
If .Execute(findtext:=sStartText) Then
StartReformat = rngSearch.End
rngSearch.Collapse wdCollapseEnd
If .Execute(findtext:=sEndText) Then
StopReformat = rngSearch.Start
End If
End If
End With
'and return our range
Set fGetRangeBetween = oDoc.Range(StartReformat, StopReformat)
End Function
'-----------------------------------------------------------------------------------------------
' Return a table containing a bookmark
'-----------------------------------------------------------------------------------------------
Public Function fGetTableContaining(sBookmarkName As String, _
Optional oInDoc As Document) As Table
Dim rngWhere As Range

If oInDoc Is Nothing Then
Set oInDoc = ActiveDocument
End If
Set rngWhere = oInDoc.Bookmarks(sBookmarkName).Range
If Not rngWhere Is Nothing Then
If rngWhere.Information(wdWithInTable) Then
Set fGetTableContaining = rngWhere.Tables(1)
End If
End If
End Function
'-----------------------------------------------------------------------------------------------
'Delete all contents of the cell containing the passed bookmark
'-----------------------------------------------------------------------------------------------
Public Sub DeleteCellTextContaining(sBookmarkName As String, Optional oDoc As Document)
Dim rngWhere As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
Set rngWhere = oDoc.Bookmarks(sBookmarkName).Range
Set rngWhere = rngWhere.Cells(1).Range
rngWhere.Text = ""
End Sub
'-----------------------------------------------------------------------------------------------
' Delete rows which contain the passed text, if no document passed, works on activedocument
'-----------------------------------------------------------------------------------------------
Public Sub DeleteRowsWith(sThisText As String, Optional oInDoc As Document)
Dim rngSearch As Range

If oInDoc Is Nothing Then
Set oInDoc = ActiveDocument
End If

Set rngSearch = oInDoc.Content

With rngSearch.Find
.ClearFormatting
.Text = sThisText
.Wrap = wdFindContinue
Do While .Execute
If .Found Then
If rngSearch.Information(wdWithInTable) Then
rngSearch.Rows.Delete
End If
End If
Loop
End With
End Sub
'-----------------------------------------------------------------------------------------------
'DELETE ALL EMPTY ROWS IN ALL TABLES
'If no document passed, works on active document
'-----------------------------------------------------------------------------------------------
Public Sub DeleteEmptyRows(Optional oDoc As Document)
Dim oTable As Table
Dim oRow As Range
Dim oCell As Cell
Dim Counter As Long
Dim NumRows As Long
Dim TextInRow As Boolean

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
For Each oTable In oDoc.Tables 'Specify which table you want to work on.

'Set oTable = Selection.Tables(1)
' Set a range variable to the first row's range
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.Count

For Counter = 1 To NumRows

StatusBar = "Row " & Counter
TextInRow = False

For Each oCell In oRow.Rows(1).Cells
If Len(oCell.Range.Text) > 2 Then 'end of cell marker is actually 2 characters
TextInRow = True
Exit For
End If
Next oCell

If TextInRow Then
Set oRow = oRow.Next(wdRow)
Else
oRow.Rows(1).Delete
End If

Next Counter
Next oTable
End Sub
'-----------------------------------------------------------------------------------------------
'SPLIT ALL THE TABLES based on the passed split text
'works on the activedocument, if no document passed
'-----------------------------------------------------------------------------------------------
Public Sub SplitSomeTables(sSplitText As String, Optional oDoc As Document)
Dim Tbl As Table
Dim RngFnd As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If

For Each Tbl In oDoc.Tables
Set RngFnd = Tbl.Range
With RngFnd.Find
.ClearFormatting
.Text = sSplitText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
With RngFnd.Duplicate

'The next two lines break the table *after* the found row
'If .Cells(1).RowIndex < .Tables(1).Rows.Count Then
'.Tables(1).Split .Cells(1).RowIndex + 1
'The next two lines break the table *before* the found row

If .Cells(1).RowIndex > 1 Then
.Tables(1).Split .Cells(1).RowIndex
End If
.Collapse (wdCollapseEnd)
End With
Loop
End With
Next
Set RngFnd = Nothing
End Sub
'-----------------------------------------------------------------------------------------------
'Main function for reorganizing tables, inserting new tables at insertion range
'-----------------------------------------------------------------------------------------------
Public Sub ReorganizeTables(rngInsert As Range, Optional oDoc As Document)
Dim oNewDoc As Document
Dim colHeadingTables As Collection
Dim colDataTables As Collection
Dim i As Integer
Dim iCount As Integer
Dim rngWhere As Range

On Error GoTo l_err
'get our data
If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
Set rngWhere = rngInsert
Set colHeadingTables = fGetTables(oDoc, ttHeading)
Set colDataTables = fGetTables(oDoc, ttData)

'check the counts
iCount = colHeadingTables.Count
If iCount <> colDataTables.Count Then
MsgBox "You do not have the same number of Heading tables as Data tables." & vbCr & _
"Proceeding anyway...", vbInformation, "Check results!"
If iCount < colDataTables.Count Then
iCount = colDataTables.Count
End If
End If

'cycle through the collection with the most number of tables
For i = 1 To iCount
On Error Resume Next
colHeadingTables(i).Range.Copy
'this item doesn't exist, so skip inserting
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr
rngWhere.Collapse wdCollapseEnd
End If

On Error Resume Next
colDataTables(i).Range.Copy
If Err.Number = 0 Then
On Error GoTo l_err
rngWhere.Paste
rngWhere.Collapse wdCollapseEnd
rngWhere.InsertAfter vbCr & vbCr
rngWhere.Collapse wdCollapseEnd
End If
Next

'redefine the start of our range
rngWhere.Start = colHeadingTables(1).Range.Start
'see if the first data table is earlier
If colDataTables(1).Range.Start < rngWhere.Start Then
rngWhere.Start = colDataTables(1).Range.Start
End If

'and the end of our range
rngWhere.End = colDataTables(colDataTables.Count).Range.End
If colHeadingTables(colHeadingTables.Count).Range.End > rngWhere.End Then
rngWhere.End = colHeadingTables(colHeadingTables.Count).Range.End
End If

'and delete our original tables
rngWhere.Delete

l_exit:
Exit Sub
l_err:
MsgBox Err.Number & vbCr & Err.Description & vbCr & _
"Better ask VBAExpress what's going on!", vbCritical, "Error!"
Resume l_exit
End Sub
'-----------------------------------------------------------------------------------------------
'Primary tester for the type of table -- this may need to become more robust
'if the table criteria changes
'-----------------------------------------------------------------------------------------------
Public Function fGetTableType(oTable As Table) As MyTableTypes
Dim sCellText As String
Dim lRet As MyTableTypes

On Error GoTo l_err

'initialize unknown return
lRet = ttUnknown

With oTable
'get the text of the first cell in the table
sCellText = .Range.Cells(1).Range.Text
'remove the end of cell marker
sCellText = Replace(sCellText, Chr(13) & Chr(7), "")

'check the content to determine the type
If sCellText = "" Then
lRet = ttHeading
ElseIf VBA.UCase(sCellText) = "UNITS" Then
lRet = ttData
End If

End With

l_exit:
fGetTableType = lRet
Exit Function
l_err:
lRet = ttUnknown
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
'return a collection of appropriate table types in the passed document
'-----------------------------------------------------------------------------------------------
Public Function fGetTables(oDoc As Document, lReturnWhatType As MyTableTypes) As Collection
Dim colRet As Collection
Dim oTable As Table

On Error GoTo l_err
'create a new instance
Set colRet = New Collection

For Each oTable In oDoc.Tables
'only add the appropriate types to our collection
If fGetTableType(oTable) = lReturnWhatType Then
colRet.Add oTable
End If
Next

Set fGetTables = colRet
l_exit:
Exit Function
l_err:
Set fGetTables = Nothing
Resume l_exit
End Function

[fredlo2010]

Hello Frosty,

The code runs perfectly except for the error you where telling me about.

Whats happening is that "Sale" is not that the same level as "List Price" So let me be a little more graphical here

All cells that benefit from "List Price" "Description"

List Price Descr

[Frosty]

Hmm... I *think* I know what you mean. Does the following work?

1. Comment out the line of code "AdjustTableCells "Sale", "", "" in the main routine.

2. Replace the AdjustTableCells sub with the following (this uses a function I wrote for the reorganize routine in order to "skip" performing any action on the pink (heading) table.


'-----------------------------------------------------------------------------------------------
' Pass in find text and replace text-- and replaces cells 1 and 2, if the text is found in a table
'-----------------------------------------------------------------------------------------------
Public Sub AdjustTableCells(sFindText As String, sCell1Text As String, sCell2Text As String, _
Optional oDoc As Document)
Dim r As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
Set r = oDoc.Range
With r.Find
Do While .Execute(findtext:=sFindText, Forward:=True) = True
If r.Information(wdWithInTable) Then
'don't adjust our table heading type?
If fGetTableType(r.Tables(1)) <> ttHeading Then
With r
.Rows(1).Cells(1).Range.Text = sCell1Text
.Rows(1).Cells(2).Range.Text = sCell2Text
.Collapse 0
End With
End If
End If
Loop
End With
End Sub

Again, I give it to you in piecemeal so that you can learn as you go.

Using F8 to step through code, and F9 to set breakpoints to run code to that spot, will be a big step to learning how to troubleshoot your own code.

Let me know if the above doesn't make sense.

[Frosty]

Conceptually speaking, you should never write code to fix problems other code you've written has caused. I think that's how the above becomes a solution.

But you've got a lot of stuff hard-coded (text strings etc) in this routine, so you're going to need to become familiar with troubleshooting this code, since it is so specific to the document you're working on

[fredlo2010]

Sorry I posted by mistake

This a generic body table So I was saying that one table goes

Units Description List Price
25 New $47



This a very specific table that occurs 20% of the time in my documentss. Now the table with contains the word "Sales" is in a different row

Units Description List Price
Some text here + "sales" $ 47

I hope this clarifies it. That's why after running the AdjustTableCells "List Price", "Units", "Description"

The next would be now look for :Sales, when you find it, go up a cell, clear contents of cell1 and the one next to it ( because this are supposed to be blank; they just got text "Units" and "Description" from the previous code block. I have included a picture in case my exploitation was not very clear.

http://i47.tinypic.com/2cfw021.jpg

There was a little thing with the barcode. It actually deletes the text but not the row from the table. I took care of that part already....I was gonna use selection but I changed my mind and after a little bit of thinking i got it using ranges ( i bet your would be more efficient though)

==== Question here=====

What does this piece of code do?


If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If


I did the macro for the barcode without it and it works fine.



Dim rFortry As Range

Set rFortry = ActiveDocument.Bookmarks("Barcode").Range

If rFortry.Information(wdWithInTable) Then
rFortry.Rows.Delete
End If

End Sub




'REPLACE ALL USD FOR $
'FROSTY NOTE: is this necessary?

:) no its not but it makes it more viewer friendly; I think

Now i need one clarification. How do i organize all this? Do I put it all in one Module? I am confused its quite a bit of code :)

[fredlo2010]

Frosty,

The code works perfectly now.

wow thank you very much! I am extremely grateful that you decided to help me.

It will take me a while to learn your code so i can add new things and troubleshoot it, but if i made a code out of bits and pieces, consider this my new challenge.

I will have to do this because there are some things I left out because are a little sensitive that i will add to the code.

I am also ready my book so i can grip important concepts and procedures.

Thanks again for everything for real.

[fredlo2010]

Hmm... I *think* I know what you mean. Does the following work?

1. Comment out the line of code "AdjustTableCells "Sale", "", "" in the main routine.

2. Replace the AdjustTableCells sub with the following (this uses a function I wrote for the reorganize routine in order to "skip" performing any action on the pink (heading) table.


'-----------------------------------------------------------------------------------------------
' Pass in find text and replace text-- and replaces cells 1 and 2, if the text is found in a table
'-----------------------------------------------------------------------------------------------
Public Sub AdjustTableCells(sFindText As String, sCell1Text As String, sCell2Text As String, _
Optional oDoc As Document)
Dim r As Range

If oDoc Is Nothing Then
Set oDoc = ActiveDocument
End If
Set r = oDoc.Range
With r.Find
Do While .Execute(findtext:=sFindText, Forward:=True) = True
If r.Information(wdWithInTable) Then
'don't adjust our table heading type?
If fGetTableType(r.Tables(1)) <> ttHeading Then
With r
.Rows(1).Cells(1).Range.Text = sCell1Text
.Rows(1).Cells(2).Range.Text = sCell2Text
.Collapse 0
End With
End If
End If
Loop
End With
End Sub

Again, I give it to you in piecemeal so that you can learn as you go.

Using F8 to step through code, and F9 to set breakpoints to run code to that spot, will be a big step to learning how to troubleshoot your own code.

Let me know if the above doesn't make sense.


Frosty,

Do you mind reading me out the if part of this code?

Sorry for the bother. But it a little hard for me to understand

[Frosty]

Which if do you mean, Fred?

[fredlo2010]

This part

If fGetTableType(r.Tables(1)) <> ttHeading Then
With r
.Rows(1).Cells(1).Range.Text = sCell1Text
.Rows(1).Cells(2).Range.Text = sCell2Text
.Collapse 0
End With
End If

[Frosty]

That uses the same criteria by which to identify a heading table in order to skip adjusting that specific exception to exchanging the cell data.

Try using F8 to step through the code, and then watch as the document slowly changes.

[fumei]

Conceptually speaking, you should never write code to fix problems other code you've written has caused.Praise the lord.

The IF statement means that IF the table type is NOT (<> ttHeading) the type where you want to deal with the heading, then change the text on the row the text is found.

[Frosty]

Haha. Fumei explained my code better than I did. It's nice to have a second set of eyes in a thread! Thanks, Gerry!

[fredlo2010]

Guys,

I worked with the coded to make sure everything runs fine and to get a little bit more familiar with the tools and the logical thinking behind it.

I have to tell you that I have learned a lot with you.

1. There is only one little think that does not work in the code

'FORMAT BOLT THE JOBSITE

With fGetRangeBetween("Lease/Sale of our material for your project ", _
" in ")
'FROSTY NOTE: probably better to specify the value, rather than use the Toggle
'.Font.Bold = wdToggle
.Font.Bold = True
End With

2. is there a way I can place the cursor after a string so i can copy from another word document and paste it in a specific location. Well I need to do this at least two times in the document, so it will be good to create a new sub and feed the different values into the script.

Example:

I want to place my cursor one paragraph below this string

"We are pleased to provide you with our Proposal/Contract for Lease/Sale of our material for your project The project Name Comes Here in THE MOON." pg 1 of the sample

...and the same for this

"able to help me better" located in pag 14 of the sample.


Thanks a lot guys. I dont wanna push it guys but maybe you can look into this code i made for the same document. Its supposed to open an specific document and paste in the main document. The thing is that it does not work properly until i type in something on the main document. So strange. I am puzzled :)




Here is the code I used for the main sub



Public Sub Open_Description_Documents(varDoc As String)

Dim varRange As range

Documents.Open FileName:=varDoc

Selection.WholeStory
Selection.Copy
ActiveWindow.Close
Selection.PasteAndFormat (wdFormatOriginalFormatting)

End Sub


The code for one of the buttons



Private Sub CommandButton1_Click()

UserForm1.Hide

Open_Description_Documents "C:\Users\Alfredo\Dropbox\Macros for work\Sub Proposal.docx"


End Sub

[fredlo2010]

Hello guys,

Never mind the issue with the bold letters. I already found the problem it was a small typo.

Now I am working on a code to make it an sub so I can use it several times in the document

this is what I have but its not working. Any ideas?

Sub ReplaceStringWithAnother(text1 As String, text2 As String)

Dim rngSearch As Range

Set rngSearch = ActiveDocument.Content

rngSearch.Find.ClearFormatting
rngSearch.Find.Replacement.ClearFormatting
With rngSearch.Find
.Text = "text1"
.Replacement.Text = "tex2"
.Wrap = wdFindContinue

End With
rngSearch.Find.Execute Replace:=wdReplaceAll

End Sub

Code in the main routine

ReplaceStringWithAnother "USD", ""


Thanks