Блог

То, что я пытаюсь сделать, это следующее:

1. Запустите модуль. Откроется диалоговое окно выбора файлов и выберите набор файлов. Файлы всегда имеют 8-значный идентификатор в начале имени, но остальная часть имени является переменной.
2. Найдите ВСЕ строки формы «T0***» в файле word и сохраните их в массиве.
3. Откройте электронную таблицу Excel (одну электронную таблицу для всего макроса). Сообщите идентификатор файла в A1 и выпишите строку результатов поиска в B1.
4. Закройте этот файл Word, откройте следующий в списке и повторите процесс. Сообщите о своих результатах в таблицах A2 и B2. Делайте это до конца выбранного списка файлов word.

Может быть любое количество строк T0***.

До сих пор у меня получалось открывать каждый файл, а затем закрывать его. Это все, что я могу сказать. Любая помощь будет очень признательна!

 'Toolfind Macro

Sub ToolFind()
Dim idarray
Dim FileSelections
Dim j As Integer
' ------------------------------------------------------

Dim MyDialog As FileDialog, GetStr(1 To 500) As String
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)



Set Ex0 = New Excel.Application
    Set Wb0 = Ex0.Workbooks.Add




' ---------------------------------------------------------------
' *.doc? allows processing of *.doc and *.docx files.
' ---------------------------------------------------------------
With MyDialog
    .Filters.Clear
    .Filters.Add "All WORD File ", "*.doc?", 1
    .AllowMultiSelect = True

i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i   1
Next

i = i - 1
End If

Application.ScreenUpdating = False

For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Set ID = Left(GetStr(j), 8)






Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If

If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

'-----------------------------------------------------------------------'

Dim k As Long, SmArr()
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "T0***"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    k = k   1
    ReDim Preserve SmArr(k)
    SmArr(k) = .Text
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With

'go into EXCEL'

    Wb0.Sheets(1).Range("A1").Value (ID)
    Wb0.Sheets(1).Range("B1").Value (SmArr)

    Application.ScreenUpdating = True


'-----------------------------------------------------------------------




ActiveDocument.Close (wdSaveChanges)
Next j
End With
End Sub