• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 236
  • Last Modified:

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
0
bsharath
Asked:
bsharath
  • 8
  • 6
  • 4
1 Solution
 
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
 
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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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
 
hiteshgoldeneyeCommented:
'===================
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
 
hiteshgoldeneyeCommented:
'===================
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
 
hiteshgoldeneyeCommented:
>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
 
hiteshgoldeneyeCommented:
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
 
RobSampsonCommented:
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

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 8
  • 6
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now