VBA: Find a number and copy rows to another sheet?

[moso97ad]

I need need to make a code in VBA that can perform a search and copy
and paste the the rows from one sheet in excel to another. Let me
explain it.

1. The user type in a number in cell "A1" in sheet 1 and hit the
"Search-button".
2. A search for the number in "A1" will begin in sheet 1 in column
A10
to A?????? (the number is not unique, so it can occur many times).
3. If the result of the search is that the number is found 10 times,
then these 10 rows must be copied and pasted to sheet 2. BUT it is
not
all the columns that need to be pasted, let us say it is only column
A, B, C, F and G.

I have tried to use the following code, but I can't figure out how to
change the search conditions. Right now I search for the word
"Significant", but I wan't to search for a number in cell A1. How can
I rewrite the code, so it adjusts to my search conditions?

Sub CopySignificant()
'Copy cells of cols A,F,E,D from rows containing "Significant" in
'col D of the active worksheet (source sheet) to cols
'A,B,C,D of Sheet2 (destination sheet)
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1

For sRow = 1 To Range("D65536").End(xlUp).Row
'use pattern matching to find "Significant" anywhere in cell
If Cells(sRow, "D") Like "*Significant*" Then
sCount = sCount + 1
dRow = dRow + 1
'copy cols A,F,E & D
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
Cells(sRow, "F").Copy Destination:=DestSheet.Cells(dRow, "B")
Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "C")
Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D")
End If
Next sRow

MsgBox sCount & " Significant rows copied", vbInformation, "Transfer
Done"

End Sub


Best regards
M

 

[Paul Tikken]

Moso,

This might help you in the right direction!

Sub Lookup()

With Worksheets(1).Range("A1:A65536")
Set c = .Find(Cells(1, 1).Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Worksheets(2).Cells(c.Row, 1).Value = c.Value
Worksheets(2).Cells(c.Row, 2).Value = c.Cells.Offset(0, 5).Value
Worksheets(2).Cells(c.Row, 3) = c.Cells.Offset(0, 4).Value
Worksheets(2).Cells(c.Row, 4) = c.Cells.Offset(0, 3).Value
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End Sub

 

[Mike H]

Put this in a module and run it

Sub stance()
Sheets("Sheet1").Select
Dim myrange, copyrange As Range
what = Range("A1").Value
lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For x = 10 To lastrow
If Cells(x, 1).Value = what Then
Set rng1 = Range("A" & x & ":C" & x)
Set rng2 = Range("F" & x & ":G" & x)
Set rng3 = Union(rng1, rng2)
If copyrange Is Nothing Then
Set copyrange = rng3
Else
Set copyrange = Union(copyrange, rng3)
End If
End If
Next
copyrange.Copy
Sheets("Sheet2").Select
Cells(1, 1).PasteSpecial
End Sub

Mike

 

[moso97ad]

Moso,

This might help you in the right direction!

Sub Lookup()

With Worksheets(1).Range("A1:A65536")
    Set c = .Find(Cells(1, 1).Value, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
        Worksheets(2).Cells(c.Row, 1).Value = c.Value
        Worksheets(2).Cells(c.Row, 2).Value = c.Cells.Offset(0, 5).Value
        Worksheets(2).Cells(c.Row, 3) = c.Cells.Offset(0, 4).Value
        Worksheets(2).Cells(c.Row, 4) = c.Cells.Offset(0, 3).Value
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

End Sub

Thank you it works but need to be modified a little bit. If a value
occur in two or more rows, it has to copy all the rows and not just
the first row where the value occurs. Could it be the loop function I
have to modify? The result of the search also have to be presented in
row B1 and downwards in sheet2, because row A is reserved for
headlines.

 

[Paul Tikken]

Moso,

This macro will put the results in B1 downwards. And I think your right, the
loop needs adjusting. You might want to look at the solution Mike gave you.

Cheers,

Paul

Sub Lookup()

Dim lastrow As Integer

lastrow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1

With Worksheets(1).Range("A1:A65536")
Set c = .FIND(Cells(1, 1).Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Worksheets(2).Cells(lastrow, 1).Value = c.Value
Worksheets(2).Cells(lastrow, 2).Value = c.Cells.Offset(0, 5).Value
Worksheets(2).Cells(lastrow, 3) = c.Cells.Offset(0, 4).Value
Worksheets(2).Cells(lastrow, 4) = c.Cells.Offset(0, 3).Value
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End Sub

 

[Paul Tikken]

Moso,

This one will work!

Sub Lookup()

Dim lastrow As Integer
Dim c As Range


lastrow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row


With Worksheets(1).Range("A2:A65536")
Set c = .FIND(Cells(1, 1).Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Worksheets(2).Cells(lastrow + 1, 1).Value = c.Value
Worksheets(2).Cells(lastrow + 1, 2).Value = c.Cells.Offset(0,
5).Value
Worksheets(2).Cells(lastrow + 1, 3) = c.Cells.Offset(0, 4).Value
Worksheets(2).Cells(lastrow + 1, 4) = c.Cells.Offset(0, 3).Value
lastrow = lastrow + 1
Set c = .FindNext(c)
Loop Until c = Cells(1, 1).Value And c.Address = firstaddress
End If
End With

End Sub

 

[Paul Tikken]

This one also includes a msgbox;

cheers

Sub Lookup()

Dim lastrow As Integer
Dim c As Range
Dim scount As Integer

scount = 0

lastrow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row

With Worksheets(1).Range("A2:A65536")
Set c = .FIND(Cells(1, 1).Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Worksheets(2).Cells(lastrow + 1, 1).Value = c.Value
Worksheets(2).Cells(lastrow + 1, 2).Value = c.Cells.Offset(0,
5).Value
Worksheets(2).Cells(lastrow + 1, 3) = c.Cells.Offset(0, 4).Value
Worksheets(2).Cells(lastrow + 1, 4) = c.Cells.Offset(0, 3).Value
lastrow = lastrow + 1
scount = scount + 1
Set c = .FindNext(c)
Loop Until c = Cells(1, 1).Value And c.Address = firstaddress
End If
End With

MsgBox ("significant rows added = " & scount)

End Sub

 

[moso97ad]

This one also includes a msgbox;

cheers

Sub Lookup()

Dim lastrow As Integer
Dim c As Range
Dim scount As Integer

scount = 0

lastrow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row

 With Worksheets(1).Range("A2:A65536")
     Set c = .FIND(Cells(1, 1).Value, LookIn:=xlValues)
     If Not c Is Nothing Then
         firstaddress = c.Address
         Do
         Worksheets(2).Cells(lastrow + 1, 1).Value = c.Value
         Worksheets(2).Cells(lastrow + 1, 2).Value = c.Cells.Offset(0,
5).Value
         Worksheets(2).Cells(lastrow + 1, 3) = c.Cells.Offset(0, 4).Value
         Worksheets(2).Cells(lastrow + 1, 4) = c.Cells.Offset(0, 3).Value
         lastrow = lastrow + 1
         scount = scount + 1
        Set c = .FindNext(c)
        Loop Until c = Cells(1, 1).Value And c.Address = firstaddress
     End If
End With

MsgBox ("significant rows added = " & scount)

End Sub

Thank you very much.