jeudi 1 mars 2018

Read from file into worksheet if filename not in range

I have a macro that reads data from the content controls in every Word file (strFile) in a folder (FormPath) into rows in the worksheet, including inserting the Word file name in column A.

Instead of reading every Word file every time, I would like the macro to read data only from those Word files not already processed (i.e. if the filename is in column A, then ignore that file).

I have made various attempts without success, as illustrated by the commented-out code.

Help gratefully received!

Sub AA_GetFormData2()

Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim FmFld As Word.FormField, CCtrl As Word.ContentControl
Dim FormPath As String, strFile As String
Dim WkSht As Worksheet, c As Long, r As Long
Dim rngCopied As Range
Dim fname As Range

FormPath = "N:\...\ReceivedFiles\"

Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(FormPath & "*.doc*", vbNormal)
Set rngCopied = Range("A:A")

'For Each fname In Range("A:A")
'If rngCopied.Value <> strFile Then
'If fname.Value = strFile Then
'If strFile <> rngCopied.Value Then

    While strFile <> ""
      r = r + 1
      Set wdDoc = wdApp.Documents.Open(Filename:=FormPath & strFile, AddToRecentFiles:=False, Visible:=False)
      With wdDoc
        c = 1: WkSht.Cells(r, c) = strFile
        'To exclude the Word filename from the data, set c = 0. To include set c = 1: WkSht.Cells(r, c) = strFile.

        For Each FmFld In .FormFields
          c = c + 1
          With FmFld
            Select Case .Type
              Case Is = wdFieldFormCheckBox
                WkSht.Cells(r, c) = .CheckBox.Value
              Case Else
                WkSht.Cells(r, c) = .Result
            End Select
          End With
        Next
        For Each CCtrl In .ContentControls
          c = c + 1
          With CCtrl
            Select Case .Type
              Case Is = wdContentControlCheckBox
                WkSht.Cells(r, c) = .Checked
              Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
                WkSht.Cells(r, c) = .Range.Text
              Case Else
            End Select
          End With
        Next
        .Close savechanges:=False
      End With
      strFile = Dir()
    Wend
'End If
'Next fname

wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Aucun commentaire:

Enregistrer un commentaire