Hello Experts,
I need your help, to modify below VBA code, which I've found exploring the web.
I have several word documents in a folder, containing different number of tables.
Below I've pasted a picture of the word document and the result in Excel.
As you may see in the result, the top of the document, is all pasted into cell A4, and the rest in each cell.
If I do a normal copy/paste of the "top-table", it will paste it into each cell in Excel.
What I would like to achieve is, that all below yellow marked cells, should be copied into each cell in Excel, and on the same row.
Anyone who can help, modifying the code to do so?
Sample Word Doc:
Result from Macro:
/Skovgaard
I need your help, to modify below VBA code, which I've found exploring the web.
I have several word documents in a folder, containing different number of tables.
Below I've pasted a picture of the word document and the result in Excel.
As you may see in the result, the top of the document, is all pasted into cell A4, and the rest in each cell.
If I do a normal copy/paste of the "top-table", it will paste it into each cell in Excel.
What I would like to achieve is, that all below yellow marked cells, should be copied into each cell in Excel, and on the same row.
Anyone who can help, modifying the code to do so?
Sample Word Doc:
Result from Macro:
VBA Code:
Sub Main()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim LR As Long: LR = 4
Dim fil As Object
ActiveSheet.Range("A4:AZ10000").ClearContents
For Each fil In fold.Files
ImportWordTable fil.path, LR
Next fil
End Sub
Sub ImportWordTable(docPath As String, ByRef resultRow As Long)
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim tableStart As Integer
Dim tableTot As Integer
On Error Resume Next
Set wdDoc = GetObject(docPath) 'open Word file
With wdDoc
tableNo = wdDoc.tables.Count
tableTot = wdDoc.tables.Count
If tableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = tableTot
End If
For tableStart = 1 To tableTot
With .tables(tableStart)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To 5 '.Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
End Sub
/Skovgaard