Use VBA in excel to fetch data in . Docm files located in Subdirectories

Question

Good morning,

I have following problem in a VBA code that I use in Excel to pull data from forms created in Word.
If the files. Docm are inside the same folder I can pull all the data I need from the forms without problem, the problem is that the number of files became mt large and it was necessary to separate them in subdirectories for a better organization.
Follow my code below:

Sub getWordFormData()
    Dim wdApp As Object, myDoc As Object
    Dim myFolder As String, strFile As String
    Dim i As Long, j As Long
    myFolder = ThisWorkbook.Path & "\"

    If Len(Dir(myFolder)) = 0 Then
        MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Set wdApp = CreateObject("Word.Application")

    With ActiveSheet
        .Cells.Clear
        With .Range("A1:F1")
            .Value = Array("Nome", "NIS", "CPF", "Endereço", "CEP", "Bairro")
            .Font.Bold = True
        End With

        strFile = Dir(myFolder & "\*.docm", vbNormal)
        i = 1

        While strFile <> ""
            i = i + 1

            On Error Resume Next

            Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)

            .Cells(i, 1).Value = myDoc.txtNome.Text
            .Cells(i, 2).Value = myDoc.txtNis.Text
            .Cells(i, 3).Value = myDoc.txtCpf.Text
            .Cells(i, 4).Value = myDoc.txtEnd.Text
            .Cells(i, 5).Value = myDoc.txtCep.Text
            .Cells(i, 6).Value = myDoc.Combobox1.Value

            myDoc.Close SaveChanges:=False
            strFile = Dir()
        Wend

        wdApp.Quit
        Application.ScreenUpdating = True

    End With

End Sub

Is there any way to modify this code so that it can fetch data from forms . Docm that are inside the subdirectories?

Edit

Example: I have the folder of the month of June and inside it I have 50 folders each with a form . Docm, wanted to run excel from inside the June folder and grab the data from the forms that are inside the subdirectories.

Thank you very much!!!

Answer 1

There are several ways around this problem, two of them are:

1. User chooses the subfolder;
2. You receive data from all Subfolders.

Choose the subfolder

An example code of how to choose the desired folder using Filedialog, then myFolder would be changed to:

    Dim fso As Object
    Dim myFolder As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Escolha a pasta"
        .Show
    End With
    On Error Resume Next
    myFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

    If myFolder = "" Then
        GoTo CleanExit                           'Se a pasta estiver vazia
    End If

    'Seu código aqui

CleanExit:

    Set fso = Nothing

Data from all subfolders

Or data from all subfolders can be obtained with the following function in a module:

Option Explicit
Public myFolder As String
Sub teste()
    Dim subpastas As Variant

    subpastas = Listar_Subpastas

    For i = LBound(subpastas) To UBound(subpastas)
        Debug.Print subpastas(i)
    Next i
End Sub

Public Function Listar_Subpastas() As Variant
    ''''''''''''''''''''
    '==== Arquivos ===='
    ''''''''''''''''''''
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xPath As String
    Dim xWs As Worksheet
    Dim fso As Object, folder1 As Object
    Dim ncell As Long
    Dim fso_FOLDER As Object
    Dim fso_FILE As Object
    Dim vaArray     As Variant
    Dim i As Long, j As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    xPath = ThisWorkbook.Path & "\"
    Set fso_FOLDER = fso.GetFolder(xPath)

    If xPath = "" Then
        GoTo CleanExit                           'Se a pasta estiver vazia
    End If

    'https://stackoverflow.com/a/31428399/7690982
    'Encontra todos os Arquivos
    ReDim vaArray(1 To fso_FOLDER.Subfolders.Count)
    i = 1
    If fso_FOLDER.Files.Count > 0 Then
        ''Loop through each SubFolder in Folder
        For Each fso_FILE In fso_FOLDER.Subfolders
            vaArray(i) = fso_FILE
            i = i + 1
        Next fso_FILE
    Else
        MsgBox "Nenhuma subpasta encontrada em " & xPath
    End If

    'For i = LBound(vaArray) To UBound(vaArray)
    '    Debug.Print vaArray(i)
    'Next i

    Listar_Subpastas = vaArray

    'Sair do código
CleanExit:

    Set fso = Nothing
    Set fso_FOLDER = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Function

Or a code can be performed to instead of getting subfolders from the same path as the Excel file, the user can select the main folder.

And a Combobox ComboBox1 can be created in a form Userform1 with subfolders. Then a button can be created to assign the path of the desired subfolder to a global variable, in the case of the example myFolder:

And the form code to fill in the Combobox and button:

Private Sub CommandButton1_Click()
    myFolder= ComboBox1.Value
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim subpastas As Variant
    Dim i As Long
    With ComboBox1
        .Clear
        subpastas = Listar_Subpastas

        For i = LBound(subpastas) To UBound(subpastas)
            .AddItem subpastas(i)
        Next i
    End With
End Sub