Affichez une valeur de la cellule qui se trouve à côté d'une cellule contenant une valeur déjà trouvée (A1, A2).

Je veux améliorer ma recherche et je veux lRow, cellule 5 pour afficher la valeur après .Cells(lRow, 4) que es rFound.Value .

J'ai essayé avec FindNext, mais il recherche un objet spécifique. chaîne de caractères .

Et puis lRow, 6 pour afficher la valeur, qui se trouve dans la cellule après lRow, cellule 5 et ainsi de suite

Je suis à court d'idées. Y a-t-il un moyen facile de s'en sortir ?

 Else
            lRow = lRow + 1
            .Cells(lRow, 1) = wbk.Name
            .Cells(lRow, 2) = wks.Name
            .Cells(lRow, 3) = rFound.Address
            .Cells(lRow, 4) = rFound.Value
            '.Cells(lRow, 5) = rFound.FindNext(rFound.Value) //this is so wrong!
            '.Cells(lRow, 6) = wbk.Name
            '.Cells(lRow, 7) = wbk.Name
            '.Cells(lRow, 8) = wbk.Name

Voici le code complet :

Sub SearchFolder()
    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

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 'added by me

    'Change as desired
    'strPath = "T:\Rali\Excel\Test"
    'strSearch = "hey"

    strPath = ActiveSheet.Range("C10")
    strSearch = ActiveSheet.Range("E10")

    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook's Name"
        .Cells(lRow, 2) = "Worksheet's Name"
        .Cells(lRow, 3) = "Cell Address"
        .Cells(lRow, 4) = "Single - Label"
        .Cells(lRow, 5) = "Short Name"
        .Cells(lRow, 6) = "Last Name"
        .Cells(lRow, 7) = "First Name"
        .Cells(lRow, 8) = "E-Mail"
        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
                       '.Cells(lRow, 5) = rFound.FindNext(rFound.Value)
                       '.Cells(lRow, 6) = wbk.Name
                       '.Cells(lRow, 7) = wbk.Name
                       '.Cells(lRow, 8) = wbk.Name
                    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
        End With
 If lRow > 1 Then 'added by me
    MsgBox "Done"
Else
    MsgBox "Nothing found! You are one step closer to approving this credit limit request :)"
End If

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

Je vous serais très reconnaissante de votre aide ! :)