Set Found = Used Range change to look in Column H

[slohman]

I'm using this VBA Macro but I need it to look in all worksheets except "Locations" and only look in Column H and copy entire row into worksheet Locations.

Sub FindTextFromCell()
'Run from standard module, like: Module1.

Dim ws As Worksheet, Found As Range, rngNm As String
Dim myText As String, FirstAddress As String, thisLoc As String
Dim AddressStr As String, foundNum As Integer

myText = Sheets("Sheet2").Range("A1").Value

If myText = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets
With ws
Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, MatchCase:=False)

If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
m = m + 1

If m > 10 Then

MsgBox "Too many found, refine your search!"
' Exit Sub
Else

If .Name = "Sheet2" Then GoTo myNext
If .Name <> "Sheet2" Then _
Found.EntireRow.Copy _
Destination:=Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)

Set Found = .UsedRange.FindNext(Found)

Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
End With

myNext:
Next ws
End Sub

 

[Alex Blakenburg]

I am unclear on what you want to achieve with you m counter since you had also dimmed a foundNum I used foundNum instead.
Also I wasn't sure whether the maximum of 10 was per sheet or in total so I have I used per sheet.
You will need to work out what you are trying to achieve with it since it will have written rows to Locations before exiting.

Give the below a try and we can work out where you want to go from there.

Sub FindTextFromCell_Mod()
    'Run from standard module, like: Module1.
  
    Dim ws As Worksheet, Found As Range, rngNm As String
    Dim myText As String, FirstAddress As String, thisLoc As String
    Dim AddressStr As String, foundNum As Long
    Dim wsLoc As Worksheet
  
    Set wsLoc = Worksheets("Locations")
    myText = wsLoc.Range("A1").Value
  
    If myText = "" Then Exit Sub
  
    For Each ws In ThisWorkbook.Worksheets
        With ws
            Set Found = .Columns("H").Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
            foundNum = 0
            If Not Found Is Nothing And .Name <> wsLoc.Name Then
                FirstAddress = Found.Address
                Do
                    foundNum = foundNum + 1
                  
                    If foundNum > 10 Then
                        MsgBox "Too many found, refine your search!"
                        Exit Do
                    Else
                        Found.EntireRow.Copy _
                            Destination:=wsLoc.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        Set Found = .Columns("H").FindNext(Found)
                    End If
                    If Found Is Nothing Then Exit Do
                Loop While Found.Address <> FirstAddress
            End If
        End With
        Set Found = Nothing
    Next ws
End Sub

 

[slohman]

So sorry for the confusion I accidentally posted the wrong macro that I was trying to modify

Sub FindCustomerType()
    'Run from standard module, like: Module1.
    'Find all data on all sheets!
    'Do not search the sheet the found data is copied to!
    'List a message box with all the found data addresses, as well!
    Dim ws As Worksheet, Found As Range
    Dim myText As String, FirstAddress As String
    Dim AddressStr As String, foundNum As Integer

 
 Application.ScreenUpdating = False
  
    Worksheets("Location").Range("A2:Q5000").ClearContents
    
    myText = InputBox("Enter text to find")

    If myText = "" Then Exit Sub

    For Each ws In ThisWorkbook.Worksheets
    With ws
    'Do not search 'Location'!
    If ws.Name = "Location" Then GoTo myNext

    Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

    If Not Found Is Nothing Then
    FirstAddress = Found.Address

    Do
    foundNum = foundNum + 1
    AddressStr = AddressStr & .Name & " " & Found.Address & vbCrLf

    Set Found = .UsedRange.FindNext(Found)

    Found.EntireRow.Copy _
    Destination:=Worksheets("Location").Range("A65536").End(xlUp).Offset(1, 0)
    Loop While Not Found Is Nothing And Found.Address <> FirstAddress
    End If
    
    Columns("A:Q").Select


myNext:
    End With

    Next ws

    If Len(AddressStr) Then
    Worksheets("Location").Activate
    Selection.EntireColumn.HorizontalAlignment = xlHAlignLeft
    Selection.EntireColumn.AutoFit
    Else:

    MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
    End If
    
    
Application.ScreenUpdating = True
    
End Sub

 

[Alex Blakenburg]

OK try this:

Sub FindCustomerType_Mod()
    'Run from standard module, like: Module1.
    'Find all data on all sheets!
    'Do not search the sheet the found data is copied to!
    'List a message box with all the found data addresses, as well!
    
    Dim ws As Worksheet, Found As Range, rngNm As String
    Dim myText As String, FirstAddress As String, thisLoc As String
    Dim AddressStr As String, foundNum As Long
    Dim wsLoc As Worksheet
    
    Set wsLoc = Worksheets("Locations")
    wsLoc.Range("A2:Q" & wsLoc.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    
    myText = InputBox("Enter text to find")
    
    If myText = "" Then Exit Sub
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            'Do not search 'Location'!
            If ws.Name <> wsLoc.Name Then
                Set Found = .Columns("H").Find(What:=myText, LookIn:=xlValues, MatchCase:=False)
                foundNum = 0
                If Not Found Is Nothing Then
                    FirstAddress = Found.Address
                    Do
                        foundNum = foundNum + 1

                        Found.EntireRow.Copy _
                            Destination:=wsLoc.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        Set Found = .Columns("H").FindNext(Found)

                        If Found Is Nothing Then Exit Do
                    Loop While Found.Address <> FirstAddress
                End If
            End If
        End With
        Set Found = Nothing
    Next ws

End Sub