nirwanaz
04-18-2012, 06:38 AM
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
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