Macro to search rows containg a defined value and paste the results

K

Kvant

New member
Joined
Apr 1, 2016
Messages
2
Reaction score
0
Points
0
Hello.

Help me please with the following.

I want to create a macro which would search in two sheets all rows containing in the column H the searched value and return the results in another sheet (values in the column H are obtained using a formula - RIGHT($G2;5)).

For example: all searched data are located in the sheets "In" and "Out"
The result should be pasted in the sheet "Search"
Search parameter should be entered in cell B2 from the sheet "Search";

When inserting, for example, value 12558 in A2, I want that all rows from "In" and "Out", which contain in column H value 12558 to be pasted in the sheet "Search".

I have the below mentioned code but looks like it needs some adjustments (currently it searches by values located in column A from "In" and "Out" and returns wrong results.)

Can you please help me identify the error?

The Excel file is attached to this post.
Code: 
Sub SearchCasesTest()Dim i As Long
Dim sval As String
Dim nextrow As Long
Dim inSheet As Worksheet
Dim outSheet As Worksheet
Dim searchSheet As Worksheet
 
Set inSheet = ThisWorkbook.Sheets("In")
Set outSheet = ThisWorkbook.Sheets("out")
Set searchSheet = ThisWorkbook.Sheets("Search")
 
sval = searchSheet.Range("a2").Value
searchSheet.Range("A5:K1000000").ClearContents
 
 
For i = 1 To inSheet.Range("A" & inSheet.Rows.Count).End(xlUp).Row
    If inSheet.Cells(i, 1).Value = sval Then
        nextrow = searchSheet.Range("A" & searchSheet.Rows.Count).End(xlUp).Row + 1
        searchSheet.Range("A" & nextrow).Resize(, 11).Value = inSheet.Range("A" & nextrow).Resize(, 11).Value
    End If
Next i
 
For i = 1 To outSheet.Range("A" & outSheet.Rows.Count).End(xlUp).Row
    If outSheet.Cells(i, 1).Value = sval Then
        nextrow = searchSheet.Range("A" & searchSheet.Rows.Count).End(xlUp).Row + 1
        searchSheet.Range("A" & nextrow).Resize(, 11).Value = outSheet.Range("A" & nextrow).Resize(, 11).Value
    End If
Next i
Sheets("Search").Range("A2").Select

End Sub

 

Attachments

  • NotWorking_.xlsm
    205.3 KB · Views: 15
Herbds7 said:
Excel 2010 with free Power Query Add-In.
Compatible with Office 2013/2016 Pro Plus with built-in PQ.
With Append() and Merge()
No VBA macro used.
links removed due to: "To be able to post links or images your post count must be 5 or greater. You currently have 1 posts.

Please remove links from your message, then you will be able to submit your post."
Click to expand...

Hello.

Thank you for your answer.

Our company has a license only for Excel 2010, and my boss asked me to find a macro based solution.

Is there a possibility to make the macro provided by me to work properly?
 
Here's how I would do it.
Code: 
Sub SearchCasesTest()
    Dim lr As Long
    Dim sval As String
    Dim inSheet As Worksheet
    Dim outSheet As Worksheet
    Dim searchSheet As Worksheet

Set inSheet = ThisWorkbook.Sheets("In")
Set outSheet = ThisWorkbook.Sheets("out")
Set searchSheet = ThisWorkbook.Sheets("Search")

sval = searchSheet.Range("a2").Value
searchSheet.Range("A5:K1000000").ClearContents

With inSheet
    'remove any existing filters
    .AutoFilterMode = False
    'determine last row
    lr = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'filter on single column
    .Range("H1:H" & lr).AutoFilter field:=1, Criteria1:=sval
    'copy filtered results if there are any
    If .Range("H1:H" & lr).SpecialCells(xlCellTypeVisible).Cells.Count - 1 > 0 Then
        'copy and paste results to searchSheet
        .UsedRange.Offset(1).Resize(lr - 1).Copy
        searchSheet.Range("A" & searchSheet.Range("A" & searchSheet.Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
    End If
    'remove filter
    .AutoFilterMode = False
End With

With outSheet
    'remove any existing filters
    .AutoFilterMode = False
    'determine last row
    lr = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'filter on single column
    .Range("H1:H" & lr).AutoFilter field:=1, Criteria1:=sval
    'copy filtered results if there are any
    If .Range("H1:H" & lr).SpecialCells(xlCellTypeVisible).Cells.Count - 1 > 0 Then
        'copy and paste results to searchSheet
        .UsedRange.Offset(1).Resize(lr - 1).Copy
        searchSheet.Range("A" & searchSheet.Range("A" & searchSheet.Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
    End If
    'remove filter
    .AutoFilterMode = False
End With

Application.CutCopyMode = False
Sheets("Search").Range("A2").Select

End Sub
 
You must log in or register to reply here.
Back
Top