Импорт первой строки текста в каждой строке / столбце таблицы Word в Excel с использованием VBA - PullRequest
Новая
       4

Импорт первой строки текста в каждой строке / столбце таблицы Word в Excel с использованием VBA

0 голосов
/ 09 октября 2019

У меня есть макрос, который я использую для импорта содержимого таблиц в файлах Word на лист Excel. Текущий сценарий работает хорошо, но бывают случаи, когда в этой строке возникает ошибка, при обработке файла, где содержимое одного из столбцов становится очень длинным: 

  .Paste Destination:=.Range("A" & r)

Мне не нужно полное содержимоетекста в каждом столбце. Я хотел бы изменить это, чтобы копировать только первую строку текста или определенное количество символов в каждой строке / столбце таблицы.

Есть ли способ сделать это?

Вот скрипт, который я сейчас использую: 

Sub GetFirstTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Tables(1)
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13^l]"
        .Replacement.Text = Chr(182)
        .Forward = True
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
      End With
      .Columns.Add
      .Cell(1, 8).Range.Text = Split(strFile, ".doc")(0)
      .Range.Copy
    End With
    With ActiveSheet
      r = .Cells(.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then r = r + 2
      .Paste Destination:=.Range("A" & r)
    End With
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
ActiveSheet.UsedRange.Replace What:=Chr(182), Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

1 Ответ

0 голосов
/ 23 октября 2019

Оказывается, что ошибка произошла из-за того, что таблицы были встроены в анализируемые таблицы, а не из-за длины текста в ячейке.

Зависание произойдет в этой строке во времяобработка файла .docx со встроенными таблицами: 

.Paste Destination:=.Range("A" & r)

После удаления таблиц из файла макрос работает как чемпион!

...