How to copy cell data to below cell data based on adjacent cell data in excel using macro vba?

Question

Using the below code, I found repeating cell value for 1st row as with last version row value. Please see my code & image as well. I an getting repeated for 1st version data & 2nd version data. I checked my code properly, but do not know where I am doing it wrong. Can anybody help me here please.

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

As I wrote on your previous question ( How to achieve cell copy to the last row in excel using vba? ). This apparently works but only not for the last instance of Version.

You should try this. It pastes the values in A and B that are in the row next to were there is Version in column C as long as column C is not equal to version, and when it equals version it jumps to the next set of data.

It works now, it had a problem when it was in the row that had version in it and had columns a and b filled with data. Now it works:

                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

Before: After

Now inside your code:

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

I got new code from TS. Therefore I will write a complete new answer, as the old one is still a solution, but not anymore based on the code from 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

This unfortunately throws up the error: "run time error 1004, Method Range of object_Global failed" and currently I am at a loss here. It occurs on this line With Range("A2:A" & LRA) Also setting the Range using Range(Cells(),Cells()) throws the same error. I can't run the code myself as it is too large, and links to too many other things only TS has. We have been discussing a lot in chat but I can't find the solution. Anyone has a clue?