Can this macro be modified

Hi,/

This macro searches for a text and copies the whole row to a sheet.

Sub FindAndCopy()
         Dim SourceSheet As Worksheet: Set SourceSheet = ActiveSheet
         Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
         Dim FindStr As String
         Dim FindCell As Range
         Do
             FindStr = InputBox("Enter Text to find.", "Enter Text")
             If FindStr <> "" Then
                 Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                 If Not FindCell Is Nothing Then
                     FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                 Else
                     MsgBox FindStr & " not found."
                 End If
             End If
         Loop While FindStr <> ""
     End Sub


What i want is i have many sheets in the excel.So need to search all sheets and copy the data to a sheet.

Regards
Sharath
LVL 11
bsharathAsked:
Who is Participating?
 
RobSampsonConnect With a Mentor Commented:
Sure, here you go:
'===================
Sub FindAndCopy()
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range, FF As Integer
    FF = FreeFile
    strFilePath = "C:\Temp\Temp\Test Script\SearchTerms.txt"
    Open strFilePath For Input As #FF
    'Open ActiveWorkbook.Path & "\SearchTerms.txt" For Input As #FF
    Do Until EOF(FF)
        Line Input #FF, FindStr
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        lngRow = NewSheet.Cells(Rows.Count, "A").End(xlUp).Row
                        FindCell.EntireRow.Copy NewSheet.Cells(lngRow + 1, "A")
                        NewSheet.Cells(lngRow + 1, Cells(lngRow + 1, 256).End(xlToLeft).Column + 1).Value = SourceSheet.Name
                    Else

                    End If
                End If
            Next
        End If
    Loop
    Close FF
End Sub
'===============

Regards,

Rob.
0
 
RobSampsonCommented:
Sharath, this will work:

'===================
Sub FindAndCopy()
      Dim SourceSheet As Worksheet
      Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
      Dim FindStr As String
      Dim FindCell As Range
      Do
            FindStr = InputBox("Enter Text to find.", "Enter Text")
            If FindStr <> "" Then
                  For Each SourceSheet In ActiveWorkbook.Sheets
                        Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                        If Not FindCell Is Nothing Then
                            FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Else
                            MsgBox FindStr & " not found."
                        End If
                  Next
            End If
      Loop While FindStr <> ""
End Sub
'===============

Regards,

Rob.
0
 
bsharathAuthor Commented:
Thanks Chencking this.

Any way to take the search details from the txt file
0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

 
bsharathAuthor Commented:
In the end of each search can it tell which sheet has it copied from.As i have many places where thedata ids found and get too many confusions.
0
 
RobSampsonCommented:
Sharath, this will put the sheet name that the string was found into column B.
'===================
Sub FindAndCopy()
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range
    Do
        FindStr = InputBox("Enter Text to find.", "Enter Text")
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        NewSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SourceSheet.Name
                    Else
                        MsgBox FindStr & " not found."
                    End If
                End If
            Next
        End If
    Loop While FindStr <> ""
End Sub
'===============

Regards,

Rob.
0
 
bsharathAuthor Commented:
If you can help me the same thing but the names to be taken from the txt file.
I can raise a new Q
0
 
RobSampsonCommented:
Try this, which also includes the reading from the text file called SearchTerms.txt in the same path as the excel document.
'===================
Sub FindAndCopy()
    ' THIS EXCEL FILE MUST INCLUDE A REFERENCE TO "MICROSOFT SCRIPTING RUNTIME"
    ' CLICK TOOLS --> REFERENCES, AND TICK "MICROSOFT SCRIPTING RUNTIME"
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range
    Dim oFSO As New FileSystemObject
    Dim oFS
    Set oFS = oFSO.OpenTextFile(ActiveWorkbook.Path & "\SearchTerms.txt")
    Do Until oFS.AtEndOfStream
        FindStr = oFS.ReadLine
        'FindStr = InputBox("Enter Text to find.", "Enter Text")
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        NewSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SourceSheet.Name
                    Else
                        MsgBox FindStr & " not found."
                    End If
                End If
            Next
        End If
    Loop
End Sub
'===============

Regards,

Rob.
0
 
bsharathAuthor Commented:
I get this error.

---------------------------
Microsoft Visual Basic
---------------------------
Can't execute code in break mode
---------------------------
OK   Help  
---------------------------

CLICK TOOLS --> REFERENCES, AND TICK "MICROSOFT SCRIPTING RUNTIME"

I am not able to find this in 2007
0
 
Hitesh ManglaniCommented:
'===================
Sub FindAndCopy()
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range,FF as Integer
    FF=FreeFile
    Open "C:\FileName.txt" For Input as #FF
    Do Until EOF(FF)
        Line Input #FF,FindStr
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        NewSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SourceSheet.Name
                    Else
                        MsgBox FindStr & " not found."
                    End If
                End If
            Next
        End If
    Loop
    Close FF
End Sub

0
 
bsharathAuthor Commented:
Ok but if not found it asks me to click ok. Can you over ride this.
Can i get from which sheet the data is taken from at the end.
0
 
Hitesh ManglaniCommented:
'===================
Sub FindAndCopy()
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range,FF as Integer
    FF=FreeFile
    Open "C:\FileName.txt" For Input as #FF
    Do Until EOF(FF)
        Line Input #FF,FindStr
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        FindCell.EntireRow.Copy NewSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        NewSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SourceSheet.Name
                    Else

                    End If
                End If
            Next
        End If
    Loop
    Close FF
End Sub


0
 
Hitesh ManglaniCommented:
>Can i get from which sheet the data is taken from at the end
Yes u can but where do you want this result?
0
 
bsharathAuthor Commented:
Results in the end of each row...
0
 
RobSampsonCommented:
Sharath,

Try this one:
'=============
Sub FindAndCopy()
    Dim SourceSheet As Worksheet
    Dim NewSheet As Worksheet: Set NewSheet = Worksheets.Add
    Dim FindStr As String
    Dim FindCell As Range, FF As Integer
    FF = FreeFile
    Open ActiveWorkbook.Path & "\SearchTerms.txt" For Input As #FF
    Do Until EOF(FF)
        Line Input #FF, FindStr
        If FindStr <> "" Then
            For Each SourceSheet In ActiveWorkbook.Sheets
                If SourceSheet.Name <> NewSheet.Name Then
                    Set FindCell = SourceSheet.Cells.Find(FindStr, , xlValues, xlWhole)
                    If Not FindCell Is Nothing Then
                        lngRow = NewSheet.Cells(Rows.Count, "A").End(xlUp).Row
                        FindCell.EntireRow.Copy NewSheet.Cells(lngRow + 1, "A")
                        NewSheet.Cells(lngRow + 1, Cells(lngRow + 1, 256).End(xlToLeft).Column + 1).Value = SourceSheet.Name
                    Else

                    End If
                End If
            Next
        End If
    Loop
    Close FF
End Sub
'=============

Regards,

Rob.
0
 
bsharathAuthor Commented:
Can i specify the txt path to a different location?
0
 
Hitesh ManglaniCommented:
yes you can specify a txt path to  different location
0
 
RobSampsonCommented:
Sharath, yes, you can specify a different location for the text file by changing this line:
Open ActiveWorkbook.Path & "\SearchTerms.txt" For Input As #FF

but, to make things a little easier in future (to change it again), use these two lines in place of that one:
strFilePath = "C:\TextFile.txt"
Open strFilePath For Input As #FF

Regards,

Rob.
0
 
bsharathAuthor Commented:
RobSampson,

Can you put in the full code here again.

I get an error compiling
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.