根据范围搜索结果复制单元格值

Question

I am a newbie to VB so I am sure this is easily solved for many here. I have a number of workbooks with same layout. I need a macro where I can enter a value via dialog box and search all workbooks and worksheets for the value i input. When that value is found the workbook, worksheet, cell location, cell value, and a cell value from a nominated column (can be fixed in code) in that row is copied to a new worksheet.

I have pilfered from the internet some code to do all but the last bit of copying the cell value from the column.

I hope this makes sense and someone can help.

Current code:

Sub Ladderload()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim LRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim Target As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    strPath = "C:\Users\hilldes\ladderload"

    strSearch = Application.InputBox("Enter ladder ID Number:", "Input Box Text", Type:=2)

    Set wOut = Worksheets.Add
    LRow = 1
    With wOut
        .Cells(LRow, 1) = "Workbook"
        .Cells(LRow, 2) = "Worksheet"
        .Cells(LRow, 3) = "Cell"
        .Cells(LRow, 4) = "Text in Cell"

        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)

        strFile = Dir(strPath & "\*.xls*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)

            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find(strSearch)

                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address

                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        LRow = LRow + 1
                        .Cells(LRow, 1) = wbk.Name
                        .Cells(LRow, 2) = wks.Name
                        .Cells(LRow, 3) = rFound.Address
                        .Cells(LRow, 4) = rFound.Value

                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)

                Loop While strFirstAddress <> rFound.Address
            Next

            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit

    Target = strSearch 'Range("D2")
    If Target = "" Then Exit Sub
    'On Error GoTo Badname
    ActiveSheet.Name = Left(Target, 31)
    'Exit Sub
'Badname:
    'MsgBox "Please revise the entry in A1." & Chr(13) _
    '& "It appears to contain one or more " & Chr(13) _
    '& "illegal characters." & Chr(13)
    'Range("A1").Activate

    End With
    MsgBox "Done"

ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Answer 1

'yourWantedColumn = 4 or yourWantedColumn = "H"
.Cells(LRow, 5) = rFound.EntireRow.Cells(1,yourWantedColumn).Value

Answer 2

You could try to offset your value.

.Cells(LRow, 5) = rFound.Offset(0,[number of columns away]).value

Change [number of columns away] to how many columns away the data you are looking for is, this value can be positive or negative.