Getting adjacent cell values in msgbox-CodePudding

I have a table with two columns. I want to filter the first column and search which cell contains "Valid" and return the adjacent cell value in a msgbox.

The msgbox should contain all adjacent cell values. How can I do it?

Thanks

CodePudding user response：

Sub Fstr
Dim str as String
For i=1 To ActiveSheet.UsedRange.count
if InStr(1,Cells(i,1),"Valid")>0 then str=str & CStr(Cells(i.1) & vbCrLf
Next i
MsgBox str

End Sub

CodePudding user response：

Looked Up Values to String

In a worksheet (wsName) of the workbook containing this code (ThisWorkbook), finds the cells containing the criterion (Criterion) in one column (CriteriaColumn), and writes the values in the same row of another column (ResultsColumn) to a string (rString) and finally displays the string in a message box.

Sub LookedUpValuesToString()
    
    ' Define constants.
    
    Const wsName As String = "Sheet1"
    Const CriteriaColumn As String = "A"
    Const ResultsColumn As String = "C"
    Const FirstRow As Long = 2
    Const Criterion As String = "Value"
    Const Delimiter As String = vbLf
    
    ' Reference the column ranges ('crg', 'rrg').
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    Dim cfCell As Range: Set cfCell = ws.Cells(FirstRow, CriteriaColumn)
    Dim clCell As Range
    Set clCell = ws.Cells(ws.Rows.Count, CriteriaColumn).End(xlUp)
    
    Dim crg As Range: Set crg = ws.Range(cfCell, clCell)
    Dim rrg As Range: Set rrg = crg.EntireRow.Columns(ResultsColumn)
    Dim rCount As Long: rCount = crg.Rows.Count
    
    ' Write the values from the column ranges to arrays ('cData', 'rData')
    
    Dim cData() As Variant
    Dim rData() As Variant
    
    If rCount = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rrg.Value
    Else
        cData = crg.Value
        rData = rrg.Value
    End If
     
    ' Loop and build the resulting string ('rString').
     
    Dim r As Long
    Dim rString As String
    
    For r = 1 To rCount
        If StrComp(CStr(cData(r, 1)), Criterion, vbTextCompare) = 0 Then
            rString = rString & CStr(rData(r, 1)) & Delimiter
        End If
    Next r
    
    ' Inform.
    
    If Len(rString) = 0 Then
        MsgBox "No criteria found.", vbExclamation
        Exit Sub
    End If
    
    rString = Left(rString, Len(rString) - Len(Delimiter))
    
    MsgBox "Found the following:" & vbLf & vbLf & rString, vbInformation
    
End Sub