Extract matched data from a table to another worksheet in Excel VBA

Question

I've got a sample table in Sheet1 as below:

Location    Model   Part #
BF03    200W    40536573
BF04    200W    40536573
CV01    120W    40536585
CV02    135W    20085112
CV03    900W    20349280
CV04    135W    20085112

As a reference data of BF03 is in cell B6.

What I need it to do is: A) When user typed part number (ex: 40536573) in Sheet3 say cell A1, only the matched location will be picked up B) The picked up "location" value will be tabulated in Sheet2 starting from cell A6.

The output will look something like this:

Location    Model   Part #
BF03    200W    40536573
BF04    200W    40536573

To make matter more complicated, I would then need to have the "Location" data to be concatenated into a string and store it in Sheet 2 Cell A2.

I'm guessing we need to do a For Loop count rows but I couldn't get any reference on how to write it properly.

Below are what my error "OVERFLOW" code looks like

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim FindMatch As String
    Dim Rng As Range
    Dim counter As Integer
    counter = ActiveWorkbook.Worksheets("Sheet2").Range("A6", Worksheets("Sheet2").Range("A6").End(xlDown)).Rows.Count
    For i = 6 To counter
    'Get the value from other sheet set as FindMatch
    FindMatch = Sheets("Sheet3").Cell("A1").Value
    'Find each row if matches the desired FindMatch
    If Trim(FindMatch) <> "" Then
        With Sheets("Sheet2").Range("D" & i).Rows.Count
            Set Rng = .Find(What:=FindMatch, _
                            after:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                'copy the values required to the cell
                Cells(i, 2) = Sheets("Sheet2").Cells(Rng.Row, 2)

            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
    Next i
End Sub

Answer 1

Instead of using the .find method, I managed to use a simple for loop. Sometimes you need to think simple i guess :) I have also added a small function to clear previously used fields. If you check and give feedback if you face any problem, we can try to fix it.

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim S_Var As String
Dim copyRange As Range
Dim ws1_lastrow As Long
Dim ws2_lastrow As Long
Dim searchresult As Range

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
S_Var = ws3.Range("A1").Value
ws1_lastrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Set copyRange = ws1.Range("A1:C" & ws1_lastrow)

'Clear Data
ws2.Range("A2").Value = ""
If Range("A7").Value <> "" Then
ws2.Range("A7:C" & ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row).Value = ""
End If

'Searchin through the sheet1 column1
For i = 2 To ws1_lastrow
    If ws1.Range("C" & i) = S_Var Then
        ws2_lastrow = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
        ws1.Range("A" & i & ":C" & i).Copy Destination:=ws2.Range("A" & ws2_lastrow + 1)
    End If
Next


'Adding location to sheet2 A2 as string
ws2_lastrow = ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row
For i = 7 To ws2_lastrow 'starting from 7, where location starts
    If ws2.Range("A2").Value = "" Then
        ws2.Range("A2").Value = ws2.Range("A" & i).Value
        Else
        ws2.Range("A2").Value = ws2.Range("A2").Value & "," & ws2.Range("A" & i).Value
    End If
Next