Question

使用下面的代码，我发现第一行的重复单元格值与上一版本的行值一样。请参阅我的代码＆amp;图像也是如此。我重复第一版数据＆amp;第二版数据。我正确检查了我的代码，但不知道我做错了什么。请有人帮助我。

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
Dim row, lastRow As Integer
Dim LRA As Long
Dim LRB As Long
Dim row2 As Long

outRow = 1 'you appear to want to start at the first 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
            Found = InStr(singleLine, "Application")
            If Found > 0 Then
                resultId = singleLine
                Exit For
            End If
        Next singleLine

        For Each singleLineZ In wrdApp.ActiveDocument.Paragraphs
            Found = InStr(singleLineZ, "Z Planning")
            If Found > 0 Then
                resultIdZ = singleLineZ
                Exit For
            End If
        Next singleLineZ

        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

        'Changes start
                For row = 1 To lastRow
                    If Cells(row, 3) = "Version" Or Cells(row, 3) = "version" Then
                        For row2 = row To lastRow
                        'If both cell are empty and C is not version, store value.
                            If row2 = row Then
                                Cells(row, 1) = resultId
                                Cells(row, 2) = resultIdZ
                            Else

                                If Cells(row2, 3) <> "Version" And Cells(row2, 3) <> "version" And Cells(row2, 1) = "" And Cells(row2, 2) = "" Then
                                   Cells(row2, 1) = Cells(row, 1)
                                   Cells(row2, 2) = Cells(row, 2)
                                ElseIf Cells(row2, 3) = "Version" Or Cells(row2, 3) = "version" Then
                                    row = row2 - 1
                                    Exit For
                                End If

                            End If
                        Next row2
                    End If
                Next row
            End With
        End With
   wrdDoc.Close False
End If
Next fileDoc
OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

Answer 1

正如我在您之前的问题（How to achieve cell copy to the last row in excel using vba?）上写的那样。这显然有效，但不是最后一个版本的实例。

你应该试试这个。只要C列不等于版本，它就会粘贴C列中有版本的行旁边的A和B中的值，当它等于版本时，它会跳转到下一组数据。

它现在有效，当它在行中有版本并且列a和b填充数据时会出现问题。现在它起作用了：

                For row = 1 To lastRow Step 1
                'If value of C cell is "Version", check column A cell and B cell
                If Cells(row, 3) = "Version" Or Cells(row, 3) = "version" Then
                    For row2 = row To lastRow
                    'If both cell are empty and C is not version, store value.
                    If row2 = row Then
                    Else

                        If Cells(row2, 3) <> "Version" And Cells(row2, 3) <> "version" And Cells(row2, 1) = "" And Cells(row2, 2) = "" Then
                            Cells(row2, 1) = Cells(row, 1)
                            Cells(row2, 2) = Cells(row, 2)
                        ElseIf Cells(row2, 3) = "Version" Or Cells(row2, 3) = "version" Then
                            row = row2 - 1
                            Exit For
                        End If

                    End If
                    Next row2
                End If
            Next row

之前：后

现在在你的代码中：

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
Dim row, lastRow As Integer
Dim LRA As Long
Dim LRB As Long
Dim row2 As Long

outRow = 1 'you appear to want to start at the first 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
                Found = InStr(singleLine, "Application")
                If Found > 0 Then
                    resultId = singleLine
                    Exit For
                End If
            Next singleLine

            For Each singleLineZ In wrdApp.ActiveDocument.Paragraphs
                Found = InStr(singleLineZ, "Z Planning")
                If Found > 0 Then
                    resultIdZ = singleLineZ
                    Exit For
                End If
            Next singleLineZ

            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

            'Changes start
                    For row = 1 To lastRow
                        If Cells(row, 3) = "Version" Or Cells(row, 3) = "version" Then
                            For row2 = row To lastRow
                            'If both cell are empty and C is not version, store value.
                                If row2 = row Then
                                    Cells(row, 1) = resultId
                                    Cells(row, 2) = resultIdZ
                                Else

                                    If Cells(row2, 3) <> "Version" And Cells(row2, 3) <> "version" And Cells(row2, 1) = "" And Cells(row2, 2) = "" Then
                                       Cells(row2, 1) = Cells(row, 1)
                                       Cells(row2, 2) = Cells(row, 2)
                                    ElseIf Cells(row2, 3) = "Version" Or Cells(row2, 3) = "version" Then
                                        row = row2 - 1
                                        Exit For
                                    End If

                                End If
                            Next row2
                        End If
                    Next row
                End With
            End With
       wrdDoc.Close False
    End If
    Next fileDoc
   OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

Answer 2

我从TS获得了新代码。因此，我将写一个完整的新答案，因为旧答案仍然是一个解决方案，但不再基于TS的代码。

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 
 Dim row, lastRow As Integer 
 Dim LRA As Long 
 Dim LRB As Long 
 Dim row2 As Long 

 outRow = 1 'you appear to want to start at the first 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 
 Found = InStr(singleLine, "Application") 
 If Found > 0 Then 
 resultId = singleLine 
 Exit For 
 End If 
 Next singleLine 
 For Each singleLineZ In wrdApp.ActiveDocument.Paragraphs 
 Found = InStr(singleLineZ, "Z") 
 If Found > 0 Then 
 resultIdZ = singleLineZ 
 Exit For 
 End If 
 Next singleLineZ 
 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 

 'Changes start 
 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" Or .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 
 For row2 = row +1 to lastRow
   If Cells(row2,3) = "Version" Or Cells(row2,3) = "version")
      LRA = row2 - 1
      LRB = row2 - 1
      Exit For
   End If
 Next row2

 'New Changes for A column 

 With Range("A2:A" & LRA) 
 With .SpecialCells(xlCellTypeBlanks) 
 .FormulaR1C1 = "=R[-1]C" 
 End With 
 .Value = .Value 
 End With 
 'New changes for B column today 

 With Range("B2:B" & LRB) 
 With .SpecialCells(xlCellTypeBlanks) 
 .FormulaR1C1 = "=R[-1]C" 
 End With 
 .Value = .Value 
 End With 
 Exit For 
 End If 
 End If 
 Next row 
 End With 
 End With 
 wrdDoc.Close False 
 End If 
 Next fileDoc 
 OpenFilesInSubFolders fsoSFolder 
 Next fsoSFolder 
 End Sub

不幸的是，这引发了错误：“运行时错误1004，object_Global的方法范围失败”，目前我在这里不知所措。它出现在此行With Range("A2:A" & LRA)上。使用Range设置Range(Cells(),Cells())会引发相同的错误。我不能自己运行代码，因为它太大了，并且链接到只有TS有太多其他东西。我们在聊天中讨论了很多，但我找不到解决方案。任何人都有线索？

如何使用宏vba基于excel中的相邻单元格数据将单元格数据复制到单元格数据下面？

2 个答案: