Question

我必须从子文件夹中的许多Word文档中获取特定数据。粘贴到下一个单元格中。例如：文档的第一页包含“Application id = 1234”＆amp;下一个Word文档第一页包含“Application id = 4563”。我想将这些应用程序ID放在B列下的Excel中的新单元格中。

当我尝试使用以下代码时，我将整个第一页数据放在一列中。

Option Explicit

Dim FSO As Object
Dim strFolderName As String
Dim FileToOpenVdocx As String
Dim FileToOpenvdoc1 As String
Dim FileToOpenVdoc As String
Dim FileToOpenvdocx1 As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim fsoFolder As Object

 'To copy data from word to excel

   'Copy data from word to excel


Sub FindFilesInSubFolders()
Dim fsoFolder As Scripting.Folder
Sheets("Sheet1").Cells.Clear
FileToOpenVdocx = "*V2.1.docx*"
FileToOpenvdoc1 = "*v2.1.doc*"
FileToOpenVdoc = "*V2.1.doc*"
FileToOpenvdocx1 = "*v2.1.docx*"

If FSO Is Nothing Then
   Set FSO = CreateObject("Scripting.FileSystemObject")
End If

'Set the parent folder for the new subfolders
strFolderName = "C:\Test1"

Set fsoFolder = FSO.GetFolder(strFolderName)
Set wrdApp = CreateObject("Word.Application")

OpenFilesInSubFolders fsoFolder
wrdApp.Quit
End Sub

Sub OpenFilesInSubFolders(fsoPFolder As Scripting.Folder)
Dim fsoSFolder As Scripting.Folder
Dim fileDoc As Scripting.File
Dim wrdRng As Object
Dim strText As String
'Dim outRow As Long ' newly added

   'outRow = 1 'you appear to want to start at the second row

For Each fsoSFolder In fsoPFolder.SubFolders
For Each fileDoc In fsoSFolder.Files

        If fileDoc.Name Like FileToOpenVdocx And Left(fileDoc.Name, 1) <> "~" Then
        Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)
        Set wrdRng = wrdDoc.Content

           If wrdRng.Find.Execute(FindText:="Application ID:[0-9]{1,}", MatchWildcards:=True) = True Then
    MsgBox "Text not found!", vbExclamation
    End If
     strText = wrdRng.Text

     'Cells(outRow & "B").Value = strText 'newly added
        'outRow = outRow + 1 'newly added

       Range("B2").Value = strText

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False
       'wrdApp.Quit

       ElseIf fileDoc.Name Like FileToOpenvdoc1 And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False

       ElseIf fileDoc.Name Like FileToOpenVdoc And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False

       ElseIf fileDoc.Name Like FileToOpenvdocx1 And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False
      End If
    Next fileDoc
   'Debug.Print fsoSFolder

   OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

Answer 1

我没有那么多输入文件。所以，我无法测试你的整个代码。但我找到了一个给你。我准备了一份像你输入的文件。我用以下代码测试过。它返回我们想要的id。所以，你可以试试这个。我相信代码对您有所帮助。

Public Sub getID()

    Dim found As Integer
    Dim resultId As String

    Set wordApp = CreateObject("word.Application")

    wordApp.documents.Open ThisWorkbook.Path & "\ID1.docx"

    wordApp.Visible = True

    'Loop all content in line by line from paragraph of active document
    For Each singleLine In wordApp.ActiveDocument.Paragraphs

        'Search "Application ID" in line.
        'If found, value will be greater 0.
        found = InStr(singleLine, "Application ID")

        'If Application ID is found, get ID only
        If found > 0 Then

            'If you want the whole line, try as "resultId = singleLine"
            'The below line is separating id from that string.

            'Get ID by replacing the prefix with space.
            resultId = Trim(Replace(singleLine, "Application ID:", ""))

            MsgBox resultId

            'After getting, stop loop because not need
            Exit For

        End If

    Next singleLine

End Sub

Answer 2

尝试更换：

.img-responsive

与

Range("B2").Value = strText

这只适用于您的ID总是4位数的情况。

PS。我自己没有尝试过代码，所以请告诉我它是否有效。

或者你可以看看这个：How to find numbers from a string?并将它与一些字符串长度操作结合起来，就像我在答案中所做的那样。

从Word文档获取特定文本＆amp;粘贴到Excel中

2 个答案: