CODEWITHSUNDEEP
vbaexcel
nihal idiot
nihal idiot

Reputation: 35

How to paste values in cell based on text present in other adjacent cell using VBA?

Thanks for reading this small request. I need your help here. I am able to paste the data in a cell of particular column of excel but I wanted to paste the data depending on adjacent column cell value. I worked on it but I could not place based on adjacent cell value. Please find the below images.

My current result

I wanted to get A2, B2 values in A4, B4 respectively i.e., based on C4 "version" text in column C. Similarly, A3, B3 values has to get in A11, B11 respectively, based on C11 version. I am pulling table data from word document & here each "Application ID:****" & "Z planning-IT ID:****" & "Version" data belonging to same each document. Finally I am trying to place each document data in a proper order. But I could not make it for Columns A & B. Help me please. Here is my 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

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

Upvotes: 0

Views: 1373

Answers (1)

R.Katnaan
R.Katnaan

Reputation: 2526

Here, I got one for you. Place this piece of code in your piece of code at With wrdApp...End With. After that test the code, If sometime is wrong, let me know. Try this one:

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

Upvotes: 2

Related Questions