Hi guys,

Here is my complete code:

Option Explicit

Sub Connection11()

'On Word document
'Developer
'Design mode
'Properties


Dim OldLocation As String
Dim NewLocation As String
Dim X1 As Range
Dim BlankstoSkip As Long
Dim WsName1 As String
Dim WsName2(0 To 4) As String
Dim WsName3(0 To 1) As String
Dim Tempname As String
Dim Filename As String
Dim i As Long
Dim ii As Long
Dim strOldPath As String



OldLocation = "C:\Users\james.shaw\Desktop\New folder (2)"
NewLocation = "C:\Users\james.shaw\Desktop\New folder (2)\New folder"

BlankstoSkip = 10
ThisWorkbook.Worksheets(1).Select
line1:

Do
WsName1 = ActiveWorkbook.ActiveSheet.Name
'    WsName2(0) = "Construction Water Pump"
'   WsName2(1) = "Constr.WaterPump"
    WsName2(2) = "CW1 Pump Station"
    WsName2(3) = "ESDD Pump_Service"
    WsName2(4) = "ESDD Pump"
        For i = 0 To 4
        WsName1 = Replace(WsName1, WsName2(i), "")
        Next i
    If WsName1 = "" Or WsName1 = "Construction Water Pump" Or WsName1 = "Constr.WaterPump" Then
        ActiveSheet.Next.Select
        GoTo line1:
    End If

Filename = Range("j2")
    WsName3(0) = "TEMPLATE "
    WsName3(1) = ".DOCX"
        For i = 0 To 0
Filename = Replace(Filename, WsName3(i), "")
        Next i
        For i = 1 To 1
Tempname = Replace(Filename, WsName3(i), "")
        Next i

Set X1 = ActiveWorkbook.ActiveSheet.Range("B4")
X1.Select
For ii = 1 To BlankstoSkip + 1
Do While Not IsEmpty(X1.Offset(ii, 0))
Selection.End(xlDown).Select
Set X1 = Selection.Offset(0, 2)
ii = 1
Loop
Next ii
Range("A1", X1).Select
Selection.Copy

Dim rng As Range
strOldPath = OldLocation & "\" & Filename
Set rng = Range("A1", X1)


Application.ScreenUpdating = False
Application.EnableEvents = True

    Dim WordApp As Object
    Dim WordDoc As Word.Document
    Dim WordTable As Word.Table
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(Filename:=strOldPath)

rng.Copy

  WordDoc.Paragraphs(220).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

'Autofit Table so it fits inside Word Document
'  Set WordTable = WordDoc.Tables()
'  WordTable.AutoFitBehavior (wdAutoFitWindow)
  
  


WordDoc.SaveAs Filename:=NewLocation & "\" & Filename & WsName1 & ".DOCX"


WordDoc.Close
    Set WordDoc = Nothing
    Set WordApp = Nothing
    


ActiveSheet.Next.Select
Loop

'WordDoc.Close
'    Set WordDoc = Nothing
'    Set WordApp = Nothing

End Sub

I am curious about this part here:
  WordDoc.Paragraphs(220).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

It has take me all night, by trial and error, guessing the "220" to get my excel tables in the right spot of my word document.

I am curious to know if there is a way to get this property within a word document.

I am thinking something like "Word count" where it gives you information about an area you have highlighted?



2) I keep getting messages saying "This word document is already opened by another user", any ideas how to get around that?




Thanks guys,

Jimmy