Search for a value in a column and copy row to new sheet for all matching values in new sheet

N

nickusa99

New Member
Joined
Oct 5, 2011
Messages
4
I found this on http://www.techonthenet.com/excel/macros/search_for_string.php and it's working perfect, I am wondering if someone can help and let me know how to run this on all sheets in workbook.

I have several sheets in workbook for each country and I want to combine all search column into new one.

here is the macro :-
Sub SearchForString()


Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute



'Start search in row 7
LSearchRow = 7

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column B = "Laptops", copy entire row to Sheet2
If Range("B" & CStr(LSearchRow)).Value = "Laptops" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("CANADA").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A2
Application.CutCopyMode = False
Range("A2").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
Hi, :)

I have not tested your code, but I've just written a code that should fit your problem:

Code: 
Option Explicit
Public Sub Main()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim strTMP As String
    On Error GoTo Fin
    Application.DisplayAlerts = False
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name Like "Found_*" Then
            wksSheet.Delete
        End If
    Next wksSheet
    'strFound = "Laptops"
    strFound = InputBox("Enter search term!", "Search", "Laptops")
    If Trim(strFound) = "" Then Exit Sub
    Set wksSheetNew = Worksheets.Add(Before:=Sheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    lngLastRow = 1
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> wksSheetNew.Name Then
            Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                LookIn:=xlValues, LookAt:=xlPart)
            If rngRange Is Nothing Then
            Else
                strLink = rngRange.Value
            End If
            If Not rngRange Is Nothing Then
                strTMP = rngRange.Address
                Do
                    lngLastRow = lngLastRow + 1
                    wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                        Destination:=wksSheetNew.Cells(lngLastRow, 1)
                    intLastColumn = Cells(lngLastRow, Columns.Count).End(xlToLeft).Column + 1
                    Cells(lngLastRow, intLastColumn).Value = "Sheet"
                    wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells _
                        (lngLastRow, intLastColumn), Address:="", _
                        SubAddress:=wksSheet.Name & "!" & rngRange.Address, _
                        TextToDisplay:="Found in Sheet " _
                        & wksSheet.Name & " " & rngRange.Address
                    Set rngRange = wksSheet.Columns(2).FindNext(rngRange)
                Loop While rngRange.Address <> strTMP
                wksSheetNew.Cells.EntireColumn.AutoFit
            End If
        End If
    Next wksSheet
Fin:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name Like "Found_*" Then
                wksSheet.Delete
            End If
        Next wksSheet
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub
Here is a sample file:

Search - Found - Copy
 
Upvote 0
It works great thank you very much, it will save lot of my time. One quick question, can we change last cell which this macro added like "Found in Sheet CANADA $B$8" to "sheetname' like in this case "CANADA".

Again thanks for sharing this code.
Nick
 
Upvote 0
Hi, :)

yes: ;)

Code: 
Option Explicit
Public Sub Main()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim strTMP As String
    On Error GoTo Fin
    Application.DisplayAlerts = False
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name Like "Found_*" Then
            wksSheet.Delete
        End If
    Next wksSheet
    'strFound = "Laptops"
    strFound = InputBox("Enter search term!", "Search", "Laptops")
    If Trim(strFound) = "" Then Exit Sub
    Set wksSheetNew = Worksheets.Add(Before:=Sheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    lngLastRow = 1
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> wksSheetNew.Name Then
            Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                LookIn:=xlValues, LookAt:=xlPart)
            If rngRange Is Nothing Then
            Else
                strLink = rngRange.Value
            End If
            If Not rngRange Is Nothing Then
                strTMP = rngRange.Address
                Do
                    lngLastRow = lngLastRow + 1
                    wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                        Destination:=wksSheetNew.Cells(lngLastRow, 1)
                    intLastColumn = Cells(lngLastRow, Columns.Count).End(xlToLeft).Column + 1
                    Cells(lngLastRow, intLastColumn).Value = "Sheet"
                    wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells _
                        (lngLastRow, intLastColumn), Address:="", _
                        SubAddress:=wksSheet.Name & "!" & rngRange.Address, _
                        TextToDisplay:=wksSheet.Name
                    Set rngRange = wksSheet.Columns(2).FindNext(rngRange)
                Loop While rngRange.Address <> strTMP
                wksSheetNew.Cells.EntireColumn.AutoFit
            End If
        End If
    Next wksSheet
Fin:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name Like "Found_*" Then
                wksSheet.Delete
            End If
        Next wksSheet
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub
 
Upvote 0
That's perfect, I like this. you are genius. I know I am asking now too much:).

Is it possible we can run this on several workbooks in one folder?

Thanks
Nick :confused:
 
Upvote 0
Hi, :)

with multiselect - hold down ctrl key while clicking on the Excel files...

Code: 
Option Explicit
Public Sub Main_1()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim intFiles As Integer
    Dim varFiles As Variant
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim wkbBook As Object
    Dim strTMP As String
    On Error GoTo Fin
    varFiles = Application.GetOpenFilename( _
        FileFilter:="Excel files (*.xls*), *.xls*", _
        MultiSelect:=True)
    If VarType(varFiles) = vbBoolean Then Exit Sub
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name Like "Found_*" Then
            wksSheet.Delete
        End If
    Next wksSheet
    'strFound = "Laptops"
    strFound = InputBox("Enter search term!", "Search", "Laptops")
    If Trim(strFound) = "" Then Exit Sub
    Set wksSheetNew = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    lngLastRow = 1
    For intFiles = 1 To UBound(varFiles)
        Set wkbBook = Workbooks.Open(varFiles(intFiles))
        For Each wksSheet In wkbBook.Worksheets
            If wksSheet.Name <> wksSheetNew.Name Then
                Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                    LookIn:=xlValues, LookAt:=xlPart)
                If rngRange Is Nothing Then
                Else
                    strLink = rngRange.Value
                End If
                If Not rngRange Is Nothing Then
                    strTMP = rngRange.Address
                    Do
                        lngLastRow = lngLastRow + 1
                        wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                            Destination:=wksSheetNew.Cells(lngLastRow, 1)
                        intLastColumn = Cells(lngLastRow, Columns.Count).End(xlToLeft).Column + 1
                        Cells(lngLastRow, intLastColumn).Value = "Sheet"
                        wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells _
                            (lngLastRow, intLastColumn), Address:="", _
                            SubAddress:=wksSheet.Name & "!" & rngRange.Address, _
                            TextToDisplay:=wksSheet.Name
                        Set rngRange = wksSheet.Columns(2).FindNext(rngRange)
                    Loop While rngRange.Address <> strTMP
                    wksSheetNew.Cells.EntireColumn.AutoFit
                End If
            End If
        Next wksSheet
        wkbBook.Close False
        Set wkbBook = Nothing
    Next intFiles
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name Like "Found_*" Then
                wksSheet.Delete
            End If
        Next wksSheet
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Set wkbBook = Nothing
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub
 
Upvote 0
it works except in some rows it entered "sheet" name in between instead at the end. Which is fine I can do cut and paste.

Thanks very much solving my issue. I never worked with Macro earlier, this was my first attempt.

-Nick
 
Upvote 0
Good Morning

Following on with the below code

Sub SearchForString()


Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute



'Start search in row 7
LSearchRow = 7

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column B = "Laptops", copy entire row to Sheet2
If Range("B" & CStr(LSearchRow)).Value = "Laptops" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("CANADA").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A2
Application.CutCopyMode = False
Range("A2").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

Instead of copying the entire row - can you specific a range in the row to copy

Example B2:F2
 
Upvote 0
The macro in the link posted by NickUSA99 works great, but I was wondering how I can make sure the macro only shows the rows I pasted last (thus is my current criteria has less matches, that the rows below (that were previously filled with data from another run) will be empty? Also I was wondering how I can adapt the macro in a way that it will paste the data starting from row 6 in the next sheet?
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
256
birdman15
B
D
  • Solved
VBA to move data to new sheets based off cell values
Replies
3
Views
220
Tupe77
T
B
  • Question
worksheet looping
Replies
7
Views
606
footoo
F
D
  • Solved
Code to move rows to a new sheet.
Replies
4
Views
439
dandee14k
D
D
  • Solved
Copy row based on cell value and paste as text in another worksheet
Replies
2
Views
524
DH937
D

Forum statistics

Threads
1,215,306
Messages
6,124,160
Members
449,146
Latest member
el_gazar

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top