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

Question

我是VB的新手，因此我相信对于许多人来说，这很容易解决。 我有许多布局相同的工作簿。 我需要一个宏，可以在其中通过对话框输入值，并在所有工作簿和工作表中搜索我输入的值。 找到该值后，该行中的工作簿，工作表，单元格位置，单元格值和该行中的指定列（可以用代码固定）中的单元格值将被复制到新的工作表中。

我从互联网上窃取了一些代码来执行所有操作，除了从该列复制单元格值的最后一部分。

我希望这是有道理的，并且有人可以提供帮助。

当前代码：

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

您可以尝试抵消您的价值。

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

将[要删除的列数]更改为要查找的数据有多少列，该值可以是正数或负数。