search a specific cell in multiple tabs and output the name of the tab

[chr4and]

i want to search within multiple tabs, the value of cell B1, and output the names of the tabs that include a specific value. For example, if tabs k2 and k4 contain the value 1, in cell B1, I want an output as a new sheet, that contains the names k2 and k4.

 

[arun_eagertolearn]

Please open macros (alt+f11, then view code) and paste the below code

Input as well as results would be displayed in 'check' sheet


Sub FindSheetsB1()

Dim ws As Worksheet
Dim search_item As Variant
Dim check_sheet As Worksheet
Dim result_row As Long

Set check_sheet = ThisWorkbook.Sheets("check")

search_item = check_sheet.Range("B1").Value

result_row = 2

check_sheet.Range("B2:B" & check_sheet.Rows.Count).ClearContents


For Each ws In ThisWorkbook.Worksheets
If ws.Name <> check_sheet.Name Then
If ws.Range("B1").Value = search_item Then
check_sheet.Cells(result_row, 2).Value = ws.Name
result_row = result_row + 1
End If
End If

Next ws

check_sheet.Columns("B:B").AutoFit

End Sub

 

[chr4and]

Sub FindSheetsB1()

Dim ws As Worksheet
Dim search_item As Variant
Dim check_sheet As Worksheet
Dim result_row As Long

Set check_sheet = ThisWorkbook.Sheets("check")

search_item = check_sheet.Range("B1").Value

result_row = 2

check_sheet.Range("B2:B" & check_sheet.Rows.Count).ClearContents


For Each ws In ThisWorkbook.Worksheets
If ws.Name <> check_sheet.Name Then
If ws.Range("B1").Value = search_item Then
check_sheet.Cells(result_row, 2).Value = ws.Name
result_row = result_row + 1
End If
End If

Next ws

check_sheet.Columns("B:B").AutoFit

End Sub:

thank you very much for the immediate response. When I run the above code, i get the message: Run-time error 9: Subscript out of range

 

[arun_eagertolearn]

Hi

I think the indents were not captured properly while it got pasted

pls check below (it is an image, as pasting is not preserving the indents)
the code is the same

I had checked it and was working
pls do check


thanks

 

[arun_eagertolearn]

Also, would like to highlight that this would display results from B2 downward
Suitable modifications would have to be done in case the output target cells are different

 

[chr4and]

Also, would like to highlight that this would display results from B2 downward
Suitable modifications would have to be done in case the output target cells are different

So i rewrote the code and it compiled. But now I get Complie Error: Syntax Error. Specifically the first line of the code is in Yellow colour, and the 9th line of the code is in Green colour, if that helps you

 

[arun_eagertolearn]

I just checked again, it is working for me

Can you pls confirm that you have a sheet called 'check' in your file- in case not, please incorporate the same, where the cell to be checked could be inputted

Also, pls find the code reproduced below, using excelplus's VBA wrap feature

Sub FindSheetsB1()

    Dim ws As Worksheet
    Dim search_item As Variant
    Dim check_sheet As Worksheet
    Dim result_row As Long
    
    Set check_sheet = ThisWorkbook.Sheets("check")
    
    search_item = check_sheet.Range("B1").Value
    
    result_row = 2
    
    check_sheet.Range("B2:B" & check_sheet.Rows.Count).ClearContents

    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> check_sheet.Name Then
            If ws.Range("B1").Value = search_item Then
                check_sheet.Cells(result_row, 2).Value = ws.Name
                result_row = result_row + 1
            End If
        End If
    
    Next ws
    
    check_sheet.Columns("B:B").AutoFit
    
End Sub

 

[Fuji]

See if this is how you wanted,

Sub test()
    Dim ActiveWS As Worksheet, ws As Worksheet, myVal
    Const wsName As String = "Result"   '<--- change to suite
    Set ActiveWS = ActiveSheet
    myVal = ActiveWS.[b1]
    If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add.Name = wsName
    Sheets(wsName).[a1].CurrentRegion.Offset(1).ClearContents
    For Each ws In Worksheets
        Select Case ws.Name
            Case wsName, ActiveWS.Name
            Case Else
                If Not ws.Cells.Find(myVal, , , 1) Is Nothing Then
                    Sheets(wsName).Range("a" & Rows.Count).End(xlUp)(2) = ws.Name
                End If
        End Select
    Next
End Sub

 

[chr4and]

thank you very much.
I have another task that would like to resolve, if its possible:
I have a single sheet that in column A, (A1:A67) contains names, and in columns B to K it contains responses that these persons have given to a some questions. I want to do the following:
Go through column B, and search for the response ANS1. All the persons (in column A) that have given this response, I want them in a new tab, called ANS1. Then go through column C and do the same, i.e. search for response ANS1 and all the persons that have given this response, I want them in the tab called ANS1. And I want to do this, for all columns up to column K

 

[arun_eagertolearn]

Pls check this

Sub search_answer()

    Dim ws As Worksheet
    Dim current_ws As Worksheet
    Dim ans As String
    Dim last_row As Long
    Dim i As Long
    Dim j As Long
             
    Set current_ws = ThisWorkbook.Sheets("Answers")' Please change appropriately
    
    ans = "Ans1" 'please change appropriately
          
    lastrow = current_ws.Cells(current_ws.Rows.Count, "A").End(xlUp).Row
    
    lastQ = 10 'change as needed
    
    If Not Evaluate("ISREF('" & ans & "'!A1)") Then Sheets.Add.Name = ans 'checks whether sheet is already there
    'If Evaluate("ISREF('" & ans & "'!A1)") Then ThisWorkbook.Sheets(ans).delete
    
    Set ws = ThisWorkbook.Sheets("Ans1")
    
    'ws.Range("a1").Value = ws.Name
    'MsgBox "The sheet name is: " & ws.Name
    'ws.Range("A1:M20").ClearContents
    
    Start_row = "1"
    Start_col = "A"
    End_row = lastrow
    End_col = lastQ
    
    start_cell = Start_col & Start_row
    end_cell = ws.Cells(End_row, End_col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    
    
    ws.Range(start_cell & ":" & end_cell).Value = current_ws.Range(start_cell & ":" & end_cell).Value
            
    For j = 2 To lastQ + 1
        For i = 2 To lastrow
        
           If current_ws.Cells(i, j).Value = ans Then
                ws.Cells(i, j) = current_ws.Cells(i, j)
                ws.Range("A1").Name = current_ws.Name
            Else
                ws.Cells(i, j) = 0
            End If
        Next i
    Next j
End Sub