0

Word テーブルを含む 300 を超える Word ドキュメントがあり、必要な情報を抽出するために Excel 用の VBA スクリプトを作成しようとしています。Visual Basic はまったくの初心者です。ファイル名を最初のセルにコピーする必要があり、次のセルには抽出しようとしている情報が含まれ、その後に次のファイル名が続き、すべての単語文書が検索および抽出されるまでループします。複数の異なる方法を試しましたが、見つけることができる最も近いコードは次のとおりです。部品番号を引き出すには機能しますが、説明には機能しません。そこにある必要のない余分な情報も引き出しますが、必要な危険がある場合は、その情報を回避できます。Wordファイルの例があります（機密情報を他の情報に置き換えました）、しかし、Word文書またはWord文書の1ページ目と2ページ目のjpegを添付する方法がわかりません。ご覧いただけると助かりますので、こちらから入手する方法をお知らせください。

繰り返しになりますが、

  • 最初のセル (A1) にファイル名が必要です
  • Word文書から表3の特定のセルがExcelに必要です
  • できれば、B列に説明(B2:B?)、C列に文字と数字の混在(C2:C?)、その次の行に次のファイル名(A?)、繰り返し続ける。アイデアや提案があれば、お知らせください。写真や実際のサンプル ドキュメントを投稿できない場合は、電子メールを送信するか、その他の方法で支援を得ることができます。

これが私が操作しようとしてきたコードです。私はそれを見つけました、そしてそれはフォームの最初と最後の行のためでした、そして私はそれを機能させようとしましたが、私の目的のために役に立たなかった:

Sub GetTablesFromWord()

   'this Excel file must be in
   'the same folder with the Word
   'document files that are to be'processed.    
   Dim wApp As Word.Application  
   Dim wDoc As Word.Document  
   Dim wTable As Word.Table  
   Dim wCell As Word.Cell 
   Dim basicPath As String  
   Dim fName As String     

   Dim myWS As Worksheet  
   Dim xlCell As Range  
   Dim lastRow As Long  
   Dim rCount As Long  
   Dim cCount As Long  
   Dim RLC As Long  
   Dim CLC As Long    
   basicPath = ThisWorkbook.Path & Application.PathSeparator  
   'change the sheet name as required  
   Set myWS = ThisWorkbook.Worksheets("Sheet1")  
   'clear any/all previous data on the sheet  myWS.Cells.Clear     

   '"open" Word  Set wApp = CreateObject("Word.Application")  
   'get first .doc file name in the folder  
   'with this Excel file  
   fName = Dir(basicPath & "*.doc*")
    Do While fName <> ""
       'this puts the filename into column A to
       'help separate the table data in Excel
       myWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
       "FILE: [" & fName & "]"
       'open the Word file
       wApp.Documents.Open basicPath & fName
       Set wDoc = wApp.Documents(1)
       'if there is a table in the
       'Word Document, work with it
       If wDoc.Tables.Count > 0 Then
         Set wTable = wDoc.Tables(3)
         rCount = wTable.Rows.Count
         cCount = wTable.Columns.Count
           For RLC = 1 To rCount
           lastRow = myWS.Range("A" & Rows.Count).End(xlUp).Row + 1
           For CLC = 1 To cCount
          'if there are merged cells in the
          'Word table, an error will be
          'generated - ignore the error,
          'but also won't process the data
          On Error Resume Next
          Set wCell = wTable.Cell(RLC, CLC)
          If Err <> 0 Then
            Err.Clear
            Else
            If CLC = 1 Then 
             Set xlCell = myWS.Range("A" & lastRow)
              xlCell = wCell
            Else
              Set xlCell = myWS.Range("B" & lastRow)
              xlCell = wCell
            End If
          End If
          On Error GoTo 0
        Next
      Next
      Set wCell = Nothing
      Set wTable = Nothing
    End If ' end of wDoc.Tables.Count test
    wDoc.Close False
    Set wDoc = Nothing
    fName = Dir()
 ' gets next .doc* filename in the folder
  Loop  wApp.Quit
  Set wApp = Nothing
  MsgBox "Task Completed"
End Sub
4

1 に答える 1

0

このコードは、フォルダー内に含まれるすべての .docx ファイルをループし、データをスプレッドシートに抽出し、Word 文書を閉じて、次の文書に移動します。Word ドキュメントの名前が列 A に抽出され、ドキュメントの 3 番目のテーブル内の値が列 B に抽出されます。

   Sub wordScrape()

Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer

FolderName = "C:\code" ' Change this to the folder containing your word documents

Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files

x = 1
For Each wd In objFiles
    If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
        Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
        sh1.Cells(x, 1) = wd.Name
        sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
        'sh1.Cells(x, 3) = ....more extracted data....
        x = x + 1
    wrdDoc.Close
    End If

Next wd
wordApp.Quit
End Sub
于 2013-10-05T21:33:17.797 に答える