union , multiselection with .Find method and static range

[csalimadarka]

Hi everyone! I'm struggling with the following code which you can see below. It is totally a pain in the *** now. I really need some help.
This code is a search tool which looks for criteria from every worksheet except the summary and the list. After the .Find founds the word, then the code selects a 4 wide range around the searched word, then it copies and pastes it on the Summary sheet.
When the first searched word is found, I also would like to copy and paste the actual worksheet (where the word is found) title (on each worksheet "G3:J3") right after the search result on the summary page. This search tool could help me to find quickly which search criteria where can be found, at which sheet and some properties which also inside the title.

The result should look like this: (r1 = the first 4 columns, r2= the rest 4 columns (that is the excel header))

[TABLE="width: 500"]
<tbody>[TR]
[TD]item nr.[/TD]
[TD]Item[/TD]
[TD]Owner[/TD]
[TD]Used Capacity[/TD]
[TD]ESD_nr.[/TD]
[TD]box Owner[/TD]
[TD]Free capacity[/TD]
[TD]location[/TD]
[/TR]
</tbody>[/TABLE]

Sorry for the long description.

CODE:

Private Sub cbGO_Click()

    Dim ws As Worksheet, OutputWs As Worksheet, wbName As Worksheet
    Dim rFound As Range, r1 As Range, r2 As Range, multiRange As Range
    Dim strName As String
    Dim count As Long, lastRow As Long
    Dim IsValueFound As Boolean

    IsValueFound = False
    Set OutputWs = Worksheets("Summary")    '---->change the sheet name as required
    lastRow = OutputWs.Cells(Rows.count, "K").End(xlUp).Row

    On Error Resume Next
    strName = ComboBox1.Value
    If strName = "" Then Exit Sub
    For Each ws In Worksheets

        If ws.Name <> "lists" And ws.Name <> "Summary" Then

            With ws.UsedRange

                Set rFound = .Find(What:=strName, LookIn:=xlValues, LookAt:=xlWhole)
                If Not rFound Is Nothing Then
                    firstAddress = rFound.Address
                    
                    Do
                    
                    IsValueFound = True
                    Set r1 = Range(rFound.EntireRow.Cells(1, "B"), rFound.EntireRow.Cells(1, "D"))
                    Set r2 = Range("G3:J3")
                    Set multiRange = Application.Union(r1, r2)
                    multiRange.Copy
                    OutputWs.Cells(lastRow + 1, 11).PasteSpecial xlPasteAll
                    Application.CutCopyMode = False
                    lastRow = lastRow + 1
                    Set rFound = .FindNext(rFound)
                    
                    Loop While Not rFound Is Nothing And rFound.Address <> firstAddress

                End If
            End With
        End If
    Next ws
    On Error GoTo 0
    If IsValueFound Then
       OutputWs.Select
       MsgBox "Seach complete!"
       
    Else
        MsgBox "Name not found!"
    End If

End Sub