Snasui Excel Forum

Code: Select all

'Other code
    a = VBA.Split(Contents, Chr(7))
    j = 0
    For i = 0 To UBound(a)
    'Other code

Code: Select all

Option Explicit

Sub ImportDOCX()
  Dim FName As String, FullName As String
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Coordinates As String, Contents As String
  Dim Dest As Range, a As Variant, i As Integer, j As Integer
  
  'Prepare
  Set Dest = Range("A2")
  Set wdApp = CreateObject("Word.Application")
  Application.ScreenUpdating = False
  
  'Find the first file
  FName = Dir(ThisWorkbook.Path & "\*.docx")
  'While found
  Do While FName <> ""
    'Full pathname
    FullName = ThisWorkbook.Path & "\" & FName
    'Open the file
    Set wdDoc = wdApp.Documents.Open(FullName, False, True)
    'First paragraph are the coordinates
    Coordinates = wdDoc.Paragraphs(1).Range.Text
    'Anything else from 3rd paragraph is the content
    Contents = wdDoc.Range(wdDoc.Paragraphs(3).Range.Start).Text
    'Close the file
    
    wdDoc.Close False
    
    'Write the name into the sheet and create a hyperlink for easy access
    With Dest
      .Value = FName
      .Hyperlinks.Add Dest, FullName
    End With
    'Write the data into this row
    Dest.Offset(, 1) = Coordinates
'    Dest.Offset(, 2) = Contents

    a = VBA.Split(Contents, Chr(7))
    For i = 0 To UBound(a)
        If (i + 1) Mod 3 = 0 Then
            Dest.Offset(0, 2 + j) = VBA.Trim(a(i))
            j = j + 1
        End If
    Next i
    'Next row
    Set Dest = Dest.Offset(1)
    'Next file
    FName = Dir
  Loop
  'Done
  Application.ScreenUpdating = True
  wdApp.Quit
End Sub

Code: Select all

Option Explicit

Sub ImportDOCX()
  Dim FName As String, FullName As String
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Coordinates As String, Contents As String
  Dim Dest As Range
  
  'Prepare
  Set Dest = Range("A2")
  Set wdApp = CreateObject("Word.Application")
  Application.ScreenUpdating = False
  
  'Find the first file
  FName = Dir(ThisWorkbook.Path & "\*.docx")
  'While found
  Do While FName <> ""
    'Full pathname
    FullName = ThisWorkbook.Path & "\" & FName
    'Open the file
    Set wdDoc = wdApp.Documents.Open(FullName, False, True)
    'First paragraph are the coordinates
    Coordinates = wdDoc.Paragraphs(1).Range.Text
    'Anything else from 3rd paragraph is the content
    Contents = wdDoc.Range(wdDoc.Paragraphs(3).Range.Start).Text
    'Close the file
    wdDoc.Close False
    
    'Write the name into the sheet and create a hyperlink for easy access
    With Dest
      .Value = FName
      .Hyperlinks.Add Dest, FullName
    End With
    'Write the data into this row
    Dest.Offset(, 1) = Coordinates
    Dest.Offset(, 2) = Contents
    
    'Next row
    Set Dest = Dest.Offset(1)
    'Next file
    FName = Dir
  Loop
  'Done
  Application.ScreenUpdating = True
  wdApp.Quit
End Sub

Code: Select all

Sub extractData()

Dim wd As New Word.Application
Dim doc As Word.Document
Dim sh As Worksheet

wd.Visible = True

Set doc = wd.Documents.Open(ActiveWorkbook.Path & "\AUDIT ENGINE.docx")
Set tbls = doc.Tables
Set sh = ActiveSheet

lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

For i = 1 To 10
    sh.Cells(lr, i).Value = Application.WorksheetFunction.Clean(tbls(1).Rows(i).Cells(2).Range.Text)
Next

For i = 1 To 156
    sh.Cells(lr, 10 + i).Value = Application.WorksheetFunction.Clean(tbls(2).Rows(i).Cells(2).Range.Text)
Next



doc.Close
wd.Quit
Set doc = Nothing
Set sh = Nothing
Set wd = Nothing


End Sub