Help with Search

[nirwanaz]

Hi,
Firstly sorry for my english, i houpe you will understand what i mean. I am begginer in vb/vba
So, I found search script for excel, moded it a bit for myself, but i stucked in one place.
It works fine, if it finds what i wanted then copies all those rows in other sheet. But i want not entyre raw but only few collumns from it, and it would be graet to place those collums where i want :)
E.g. I attached book1.xls file with macro.
And i what i want is this:
Lets say i want to search all Johns.Macro does it, all three raws is copied to scheet2.
1.But (for example) i want only two collumns(not all four) to be copied and pasted - "name" and "city".
2.And it would be great that collumn "name" would be starting in cell C10 and going down, and "city" collumn would be starting in cell F10 and going down.

Its about 3 days i`m trieng to do that but no progress :(
Also i am adding this macro here in post:

Option Explicit


Sub SearchForMaterialAll()

Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim wsI As Worksheet ' will hold the value for the Input sheet i this case Sheet1
Dim wsO As Worksheet ' will hold the value for the Output sheet i this case Sheet2
Dim sCol As Long ' the last columns column number for the loop for all columns
Dim xCol As Long ' the loop counter
On Error GoTo Err_Execute
Set wsI = Sheets("Sheet1")
Set wsO = Sheets("Sheet2")
wsI.Activate

LSearchRow = 2
LCopyToRow = 2

sCol = Cells(LSearchRow, Columns.Count).End(xlToLeft).Column

Dim Message, Title, MyValue
Message = "String or number "
Title = "search"
MyValue = InputBox(Message, Title)
If Len(Trim(MyValue)) = 0 Then Exit Sub

LCopyToRow = WorksheetFunction.Max(LCopyToRow, wsO.Range("A" & Rows.Count).End(xlUp).Row)

If LCopyToRow > 2 Then
Select Case MsgBox(wsO.Name & " contains data!" & Chr(10) & _
Chr(9) & "'YES' = Append" & Chr(10) & _
Chr(9) & "'NO' = Clear existing data" & Chr(10) & _
Chr(9) & "'CANCEL' = Abort", vbYesNoCancel + vbDefaultButton1, "")
Case Is = vbYes
LCopyToRow = LCopyToRow + 1
Case Is = vbNo
LCopyToRow = 2
wsO.Range("A2:D" & WorksheetFunction.Max(2, wsO.Range("A" & Rows.Count).End(xlUp).Row)).Delete
Case Is = vbCancel
Exit Sub
End Select
End If

While Len(wsI.Range("A" & CStr(LSearchRow)).Value) > 0
For xCol = 1 To sCol ' Loop through the columns per row
If InStr(1, LCase(Cells(LSearchRow, xCol).Value), LCase(MyValue)) > 0 Then
wsI.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
wsO.Select
wsO.Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
wsI.Select
Exit For
End If
Next xCol
LSearchRow = LSearchRow + 1
Wend

Application.CutCopyMode = False
Range("A3").Select
If LCopyToRow > 2 Then
MsgBox "Total matches in '" & wsO.Name & "': " & LCopyToRow - 2, vbInformation, ""
wsO.Select
Range("A2").Select
Else
MsgBox "No match found!"
End If
Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

[mancubus]

hi.
wellcome to VBAX.

try

Sub SearchForMaterialAll()

Dim wsI As Worksheet, wsO As Worksheet
Dim rng As Range
Dim LR As Long, LC As Long
Dim i As Long, LCopyToRow As Long
Dim MyValue

On Error GoTo Err_Execute

Set wsI = Worksheets("Sheet1")
Set wsO = Worksheets("Sheet2")

MyValue = InputBox("String or number?", "Search")

If Len(Trim(MyValue)) = 0 Then
MsgBox "Please enter a valid text or number!"
Exit Sub
End If

If Application.CountIf(wsI.Cells, MyValue) = 0 Then
MsgBox "No Match. Please enter a valid text or number!"
Exit Sub
End If

If Application.CountA(wsO.Cells) = 0 Then
LCopyToRow = 10
Else
Select Case MsgBox(wsO.Name & " contains data!" & Chr(10) & _
Chr(9) & "'YES' = Append" & Chr(10) & _
Chr(9) & "'NO' = Clear existing data" & Chr(10) & _
Chr(9) & "'CANCEL' = Abort", vbYesNoCancel + vbDefaultButton1, "")
Case Is = vbYes
LCopyToRow = wsO.Cells(Rows.Count, "C").End(xlUp).Row + 1
'change C to column letter with data
Case Is = vbNo
wsO.Cells.Clear
LCopyToRow = 10
Case Is = vbCancel
Exit Sub
End Select
End If

With wsI
LR = .Cells(Rows.Count, "A").End(xlUp).Row
LC = .Cells(2, Columns.Count).End(xlToLeft).Column
For i = 2 To LR
Set rng = Range(.Cells(i, 1), .Cells(i, LC))
If Application.CountIf(rng, MyValue) > 0 Then
.Cells(i, "B").Copy wsO.Cells(LCopyToRow, "C")
.Cells(i, "C").Copy wsO.Cells(LCopyToRow, "F")
LCopyToRow = LCopyToRow + 1
End If
Next i
End With

If LCopyToRow > 10 Then
MsgBox "Total matches in '" & wsO.Name & "': " & LCopyToRow - 10, vbInformation, ""
wsO.Range("A2").Select
Exit Sub
Else
MsgBox "No match found!"
Exit Sub
End If

Err_Execute:
MsgBox "An error occurred."

End Sub