根据范围search结果复制单元格值
我是VB的新手，所以我相信在这里很容易解决这个问题。 我有许多具有相同布局的工作簿。 我需要一个macros，我可以通过对话框input一个值，并search所有工作簿和工作表中的input值。 find该值后，将该行中指定列（可用代码修复）的工作簿，工作表，单元格位置，单元格值和单元格值复制到新的工作表中。
我从互联网上偷了一些代码，除了最后一点从列中复制单元格值。
我希望这是有道理的，有人可以帮忙。
当前代码：
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 'yourWantedColumn = 4 or yourWantedColumn = "H" .Cells(LRow, 5) = rFound.EntireRow.Cells(1,yourWantedColumn).Value
你可以尝试抵消你的价值。
.Cells(LRow, 5) = rFound.Offset(0,[number of columns away]).value
将[列数]更改为您要查找的数据的列数，这个值可以是正数也可以是负数。