Question

感谢您阅读这个小请求。我需要你的帮助。我能够将数据粘贴到excel的特定列的单元格中，但我想根据相邻的列单元格值粘贴数据。我曾经研究过，但我不能根据相邻的细胞价值进行放置。请找到下面的图片。

我想分别在A4，B4中获得A2，B2值，即基于C4＆＃34;版本＆＃34;类似地，A3，B3值必须分别在A11，B11中基于C11版本获得。我从word文档＆amp;中提取表数据这里每个＆＃34;应用程序ID：****＆＃34; ＆安培; ＆＃34; Z计划-IT ID：****＆＃34; ＆安培; ＆＃34;版本＆＃34;属于同一文件的数据。最后，我试图以适当的顺序放置每个文档数据。但是我无法为A柱和A列提供它。请帮帮我。这是我的代码。

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 singleLine As Object
Dim outRow As Long ' newly added
Dim Found As String
Dim resultId As String
Dim singleLineZ As Object
Dim resultIdZ As String

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 Or fileDoc.Name Like FileToOpenvdoc1 Or fileDoc.Name Like FileToOpenVdoc Or fileDoc.Name Like FileToOpenvdocx1) And Left(fileDoc.Name, 1) <> "~" Then
            Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)
            Set wrdRng = wrdDoc.Content

            For Each singleLine In wrdApp.ActiveDocument.Paragraphs
            'Search "Application ID" in line.
            'If found, value will be greater 0.
             Found = InStr(singleLine, "Application")
            'If Application ID is found, get ID only

                If Found > 0 Then
                    'Get ID by replacing the prefix with space.
                     resultId = singleLine
                    'After getting, stop loop because not need
                     Exit For
                End If

            Next singleLine

        For Each singleLineZ In wrdApp.ActiveDocument.Paragraphs
            'Search "Application ID" in line.
            'If found, value will be greater 0.
             Found = InStr(singleLineZ, "Z Planning")
            'If Application ID is found, get ID only

                 If Found > 0 Then
                     'Get ID by replacing the prefix with space.
                      resultIdZ = singleLineZ
                     'After getting, stop loop because not need
                      Exit For
                 End If

        Next singleLineZ

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp)(1).PasteSpecial xlPasteValues
           Range("A" & outRow).Value = resultId
           Range("B" & outRow).Value = resultIdZ
           outRow = outRow + 1
           End With

           wrdDoc.Close False

      End If

   Next fileDoc
   openFilesInSubFolders fsoSFolder

Next fsoSFolder
End Sub

Answer 1

在这里，我找到了一个给你。将这段代码放在With wrdApp...End With的代码段中。在测试代码之后，如果有时候错了，请告诉我。试试这个：

Dim row, lastRow As Integer

With wrdApp

    .ActiveDocument.Tables(1).Select

    .Selection.Copy

    With ThisWorkbook.Worksheets("Sheet1")

        .Cells(Rows.count, "C").End(xlUp)(1).PasteSpecial xlPasteValues

        'getting the last row
        lastRow = .Range("C:C").End(xlDown).row

        'loop all row in column "C" for checking
        For row = 1 To lastRow Step 1

            'If value of C cell is "Version", check column A cell and B cell
            If .Range("C" & row) = "Version" Then

                'If both cell are empty, store value.
                If .Range("A" & row) = "" And .Range("B" & row) = "" Then

                    .Range("A" & row).Value = resultId
                    .Range("B" & row).Value = resultIdZ

                    Exit For

                End If

            End If

        Next row

    End With

End With

如何使用VBA基于其他相邻单元格中存在的文本在单元格中粘贴值？

1 个答案: