How to copy a column of data in a word table to active column in excel

Tyrel Smith

New Member
Joined
Nov 20, 2020
Messages
26
Office Version
  1. 2016
Platform
  1. Windows
Can someone help me please

I am trying to use vba to copy the second column of this table in word to an active column in excel(ActiveCell.Column)
Screenshot (39).png
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Hi Tyrel. You can trial this. Change the file path to suit. HTH. Dave
Code:
Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, Ws As Worksheet

On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(TblCell.RowIndex, Col) = _
      WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(TblCell.RowIndex, Col) = _
      Application.WorksheetFunction.Clean(Ws.Cells(TblCell.RowIndex, Col))
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub

ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
 
Upvote 0
Hi Tyrel. You can trial this. Change the file path to suit. HTH. Dave
Code:
Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, Ws As Worksheet

On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(TblCell.RowIndex, Col) = _
      WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(TblCell.RowIndex, Col) = _
      Application.WorksheetFunction.Clean(Ws.Cells(TblCell.RowIndex, Col))
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub

ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
Hey, thanks for the help but after changing the path and when I run it, it just loads to a point where it pops up a message saying that excel is waiting for another application to complete and when you click ok it just starts all over again. Please help
 
Upvote 0
Hi Tyrel. You can trial this. Change the file path to suit. HTH. Dave
Code:
Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, Ws As Worksheet

On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(TblCell.RowIndex, Col) = _
      WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(TblCell.RowIndex, Col) = _
      Application.WorksheetFunction.Clean(Ws.Cells(TblCell.RowIndex, Col))
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub

ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
Ok so I found the issue, in the background a window was waiting for me to respond to at coz it was asking how to open it coz it says it is only readonly but I dont have that sent but its fine I can deal with that. I forgot to ask you but can you please set the row to the active cell too coz I tried everything and i give an error message. Thanks
 
Upvote 0
Hi Tyrel I had sort of guessed that you might also want the row to be the active cell but U did not make any mention of it. Anyways, this seems to work. Dave
Code:
Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, ARow As Integer, Ws As Worksheet

On Error GoTo ErFix
Application.ScreenUpdating = False
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
ARow = ActiveCell.Row
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(ARow, Col) = _
      WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(ARow, Col) = _
      Application.WorksheetFunction.Clean(Ws.Cells(ARow, Col))
ARow = ARow + 1
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
'MsgBox "Finished"
Application.ScreenUpdating = True
Exit Sub

ErFix:
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
 
Upvote 0
Solution
Hi Tyrel I had sort of guessed that you might also want the row to be the active cell but U did not make any mention of it. Anyways, this seems to work. Dave
Code:
Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, ARow As Integer, Ws As Worksheet

On Error GoTo ErFix
Application.ScreenUpdating = False
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
ARow = ActiveCell.Row
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(ARow, Col) = _
      WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(ARow, Col) = _
      Application.WorksheetFunction.Clean(Ws.Cells(ARow, Col))
ARow = ARow + 1
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
'MsgBox "Finished"
Application.ScreenUpdating = True
Exit Sub

ErFix:
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
Thank you
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,913
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top