Transfer excel info to a word document

[dave73101]

I'm transferring information from an excel spreadsheet to a word document by clicking a command button in excel that uses visual basic code to open the word document, then searching and replacing text, e.g., find "$Address" and replace it with the contents of C7. However, I am having a problem with inserting a table by finding "$Table" in the word document and replacing it with a table, e.g., 3 columns and 5 rows.

Can anybody point me to an example?

Thanks.

 

[XL-Dennis]

Dave,

Welcome to the board

However, I am having a problem with inserting a table by finding "$Table" in the word document and replacing it with a table, e.g., 3 columns and 5 rows.

Could You provide us with the present VBA-code. This may be more convenient for You instead of receving a total new solution

Kind regards,
Dennis

 

[dave73101]

Here it is:

Private Sub CommandButton2_Click()
'This drafts the permit when the "Draft Permit" button is pushed.
On Error GoTo errorHandler
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim mywdRange As Word.Range
Dim sText As String, lText As String, LineSpace As Integer, LastName As String
Dim sCompleteness As String, sFileName As String
'Dim myRange As Word.Range

Set wdApp = New Word.Application
With wdApp
.Visible = True
.WindowState = wdWindowStateMaximize
Set wdDoc = wdApp.Documents.Open("C:New Facility Construction Permit Format.doc")
End With

'For a construction permit, update (search & replace) the standard format w/site specific information
Dim sFindText As String
Dim sReplacementText As String
Dim i As Integer

‘This does not work
With ActiveWindow
Selection.Find.ClearFormatting
With Selection.Find
.Text = "$Table1"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
NumRows:=1, Format:=wdTableFormatNone, ApplyBorders:=True, ApplyShading _
:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:=True, _
ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False, _
AutoFit:=True, AutoFitBehavior:=wdAutoFitFixed
End With


For i = 1 To 17
Select Case i
Case 1
sFindText = "$CurrentDate"
sReplacementText = Worksheets("Sheet12").Range("C39")
Case 2
sFindText = "$ChiefEngineer"
sReplacementText = Worksheets("Sheet12").Range("A60")
Case 3
sFindText = "$Reviewer1"
sReplacementText = Worksheets("Sheet12").Range("A61")
Case 4
sFindText = "$Reviewer2"
sReplacementText = Worksheets("Sheet12").Range("A62")
Case 5
sFindText = "$PermitDrafter"
sReplacementText = Worksheets("Sheet12").Range("C42")
Case 6
sFindText = "$PermitNumber"
sReplacementText = Worksheets("Sheet12").Range("C41")
Case 7
sFindText = "$CompanyName"
sReplacementText = Worksheets("Sheet12").Range("D23")
Case 8
sFindText = "$FacilityName"
sReplacementText = Worksheets("Sheet1").Range("C8")
Case 9
sFindText = "$Location"
sReplacementText = "Section " & Worksheets("Sheet1").Range("C11") & ", T" & Worksheets("Sheet1").Range("F11") & ", R" & Worksheets("Sheet1").Range("C11")
Case 10
sFindText = "$Directions"
sReplacementText = Worksheets("Sheet1").Range("C12")
Case 11
sFindText = "$SicCode"
sReplacementText = Worksheets("Sheet1").Range("C16")
Case 12
sFindText = "$PermitType"
sReplacementText = Worksheets("Sheet1").Range("C19")
Case 13
sFindText = "$ContactName"
sReplacementText = Worksheets("Sheet12").Range("D24")
Case 14
sFindText = "$ContactAddress"
If Len(Worksheets("Sheet12").Range("D27")) = 0 Then
sReplacementText = Worksheets("Sheet12").Range("D25")
Else
sReplacementText = Worksheets("Sheet12").Range("D25") & vbCrLf & Worksheets("Sheet1").Range("D26")
End If
Case 15
sFindText = "$CityStateZip"
If Len(Worksheets("Sheet12").Range("D27")) = 0 Then
sReplacementText = Worksheets("Sheet12").Range("D26")
Else
sReplacementText = Worksheets("Sheet12").Range("D27")
End If
Case 16
sFindText = "$Salutation"
If Worksheets("Sheet12").Range("E27") = 1 Then sReplacementText = "Mr."
If Worksheets("Sheet12").Range("E27") = 2 Then sReplacementText = "Mrs."
If Worksheets("Sheet12").Range("E27") = 3 Then sReplacementText = "Ms."
Case 17
sFindText = "$ContactLastName"
LineSpace = Len(Worksheets("Sheet12").Range("D24")) - InStrRev(Worksheets("Sheet12").Range("D24"), " ")
sReplacementText = Right$(Worksheets("Sheet12").Range("D24"), LineSpace)
End Select

'THIS WORKS only if page setup is new page break w/first page different and all headers/footers are "same as previous."
For Each myStoryRange In ActiveDocument.StoryRanges
myStoryRange.Find.Execute FindText:=sFindText, Forward:=True
myStoryRange.Find.Replacement.Text = sReplacementText
While myStoryRange.Find.Found
' myStoryRange.Bold = True
myStoryRange.Find.Execute _
FindText:=sFindText, Forward:=True
myStoryRange.Find.Execute _
Replace:=wdReplaceAll
Wend
While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
myStoryRange.Find.Execute FindText:=sFindText, Forward:=True
While myStoryRange.Find.Found
' myStoryRange.Bold = True
myStoryRange.Find.Execute _
FindText:=sFindText, Forward:=True
myStoryRange.Find.Execute _
Replace:=wdReplaceAll
Wend
Wend
Next myStoryRange

Next i

errorHandler:
Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
End Sub