How to achieve cell copy to the last row in excel

Question

I want to copy the data present in A9, up to the cell A12 & similarly from B9 to B12. I can copy the data present in cell A1, up to A8 successfully. But cannot copy & paste from A9 to A12 & B9 to B12. My code is unable to copy & paste for the last record.

           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" 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


                    LR = Range("B" & Rows.Count).End(xlUp).row
                        With Range("B2:B" & LR)
                            With .SpecialCells(xlCellTypeBlanks)

                            End With
                            .Value = .Value
                        End With

                    LR = Range("A" & Rows.Count).End(xlUp).row
                    With Range("A2:A" & LR)
                        With .SpecialCells(xlCellTypeBlanks)
                        .FormulaR1C1 = "=R[-1]C"
                        End With
                        .Value = .Value
                    End With
                Exit For
            End If
        End If
    Next row
End With

Answer 1

Here is my answer which might help someone. Prior to that, I would like to say thanks to Luuklag for helping me in a brilliant way.

Make sure that, you add the below references before proceeding.

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 As Long
Dim startRow As Long
Dim lastRow As Long
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")
                    startRow = .Cells(.Rows.Count, "C").End(xlUp)(2).row
                    .Cells(startRow, "C").PasteSpecial xlPasteValues
                    lastRow = .Cells(.Rows.Count, "C").End(xlUp).row
                    'Match the last pasted table with the labels
                    .Range(.Cells(startRow, "A"), .Cells(lastRow, "A")).Value = resultId
                    .Range(.Cells(startRow, "B"), .Cells(lastRow, "B")).Value = resultIdZ
                End With
            End With
            wrdDoc.Close False
        End If
    Next fileDoc
    OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

Answer 2

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:

           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 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
End With