Need some advice on the following code

I am having some problems getting the code below to work.

I have a few thousand rows of numbers listed in Column A with a number
range from 1 to 30. These numbers are spread randomly down the column.

What I am trying to do is search column A for specific instances of
each number eg 7 and then the code will copy an past those rows
containing "7" to a sheet labelled "found"

Would appreciate any mods or changes inorder to get this code working.

Kind Regards,
Dean

Sub Macro2()

Dim LastRow As Long, MyCriteria, _
rCriteriaField As Range, rPointer As Range, rCopyTo As Range

' This variable has the value of the criteria by which you intend
' to select records to extract. Lets assume you are evaluating
' the entries in column A of your source table. This can be either
' text or numeric.
Application.ScreenUpdating = False
MyCriteria = InputBox("Enter Dept Code")
If MyCriteria = "" Then Exit Sub

' Initialize a variable for the last possible record in a worksheet
If Left(Application.Version, 1) < 8 Then _
LastRow = 5570 Else LastRow = 65536

With ThisWorkbook

' Initialize a range object variable for the entire populated
' area of column B (excluding row 1 for a header)
With Worksheets("database")
Set rCriteriaField = .Range(.Cells(1, 1), _
.Cells(Application.Max(1, _
.Cells(LastRow, 1).End(xlUp).Row), 1))
End With

' Initialize a range object variable to serve as a pointer
' for the records in sheet 2
Set rCopyTo = .Worksheets("found").Cells(1, 1)
End With

' Loop through all the records in your source data table
For Each rPointer In rCriteriaField
With rPointer

' If there is a match on the criteria in col A then copy
' the record to the destination table
If .Value = MyCriteria then
.Resize(, 5).Copy
rCopyTo.PasteSpecial xlPasteValues

' Advance the pointer in your destination table to the
' next available row
Set rCopyTo = rCopyTo.Offset(1, 0)
End If
End With
Next rPointer
Application.ScreenUpdating = True
MsgBox "Search Completed"
End Sub

Sub Macro2()
Dim LastRow As Long, MyCriteria, _
rng As Range

Application.ScreenUpdating = False
MyCriteria = InputBox("Enter Dept Code")
If MyCriteria = "" Then Exit Sub

LastRow = ActiveSheet.Rows.Count

With ThisWorkbook.Worksheets("database")

.Range("A1").EntireRow.Insert
.Range("A1").Value = "Temp"
Set rng = .Range("A2").Resize(.Cells(.Rows.Count,
"A").End(xlUp).Row - 1)
.Columns("A:A").AutoFilter Field:=1, Criteria1:=MyCriteria

rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy _
ThisWorkbook.Worksheets("found").Cells(1, 1)

.Rows(1).Delete

End With

Application.ScreenUpdating = True
MsgBox "Search Completed"

End Sub

--

HTH

Bob Phillips

(remove nothere from the email address if mailing direct)

"Dean" <[email protected]> wrote in message
news:[email protected]...
> I am having some problems getting the code below to work.
>
> I have a few thousand rows of numbers listed in Column A with a number
> range from 1 to 30. These numbers are spread randomly down the column.
>
> What I am trying to do is search column A for specific instances of
> each number eg 7 and then the code will copy an past those rows
> containing "7" to a sheet labelled "found"
>
> Would appreciate any mods or changes inorder to get this code working.
>
> Kind Regards,
> Dean
>
> Sub Macro2()
>
> Dim LastRow As Long, MyCriteria, _
> rCriteriaField As Range, rPointer As Range, rCopyTo As Range
>
> ' This variable has the value of the criteria by which you intend
> ' to select records to extract. Lets assume you are evaluating
> ' the entries in column A of your source table. This can be either
> ' text or numeric.
> Application.ScreenUpdating = False
> MyCriteria = InputBox("Enter Dept Code")
> If MyCriteria = "" Then Exit Sub
>
> ' Initialize a variable for the last possible record in a worksheet
> If Left(Application.Version, 1) < 8 Then _
> LastRow = 5570 Else LastRow = 65536
>
> With ThisWorkbook
>
> ' Initialize a range object variable for the entire populated
> ' area of column B (excluding row 1 for a header)
> With Worksheets("database")
> Set rCriteriaField = .Range(.Cells(1, 1), _
> .Cells(Application.Max(1, _
> .Cells(LastRow, 1).End(xlUp).Row), 1))
> End With
>
> ' Initialize a range object variable to serve as a pointer
> ' for the records in sheet 2
> Set rCopyTo = .Worksheets("found").Cells(1, 1)
> End With
>
> ' Loop through all the records in your source data table
> For Each rPointer In rCriteriaField
> With rPointer
>
> ' If there is a match on the criteria in col A then copy
> ' the record to the destination table
> If .Value = MyCriteria then
> .Resize(, 5).Copy
> rCopyTo.PasteSpecial xlPasteValues
>
> ' Advance the pointer in your destination table to the
> ' next available row
> Set rCopyTo = rCopyTo.Offset(1, 0)
> End If
> End With
> Next rPointer
> Application.ScreenUpdating = True
> MsgBox "Search Completed"
> End Sub
>

This should be close...

Sub CopyRows()
Dim wksToSearch As Worksheet
Dim rngToSearch As Range
Dim rngFound As Range
Dim rngFoundAll As Range
Dim strFirst As String


Set wksToSearch = ActiveSheet
Set rngToSearch = wksToSearch.Columns("A")
Set rngFound = rngToSearch.Find(What:=7, _
LookAt:=xlWhole, _
LookIn:=xlValues)
If Not rngFound Is Nothing Then
Set rngFoundAll = rngFound
strFirst = rngFound.Address
Do
Set rngFoundAll = Union(rngFound, rngFoundAll)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = strFirst
rngFoundAll.EntireRow.Copy Sheets("Found").Range("A2")
'rngFoundAll.EntireRow.Copy
'Sheets("Found").Range("A2").PasteSpecial(xlValues)
'Application.cutcopymode = false
End If
End Sub

It does a standard paste, not a paste special. If you need paste special
then uncomment those lines...
--
HTH...

Jim Thomlinson


"Dean" wrote:

> I am having some problems getting the code below to work.
>
> I have a few thousand rows of numbers listed in Column A with a number
> range from 1 to 30. These numbers are spread randomly down the column.
>
> What I am trying to do is search column A for specific instances of
> each number eg 7 and then the code will copy an past those rows
> containing "7" to a sheet labelled "found"
>
> Would appreciate any mods or changes inorder to get this code working.
>
> Kind Regards,
> Dean
>
> Sub Macro2()
>
> Dim LastRow As Long, MyCriteria, _
> rCriteriaField As Range, rPointer As Range, rCopyTo As Range
>
> ' This variable has the value of the criteria by which you intend
> ' to select records to extract. Lets assume you are evaluating
> ' the entries in column A of your source table. This can be either
> ' text or numeric.
> Application.ScreenUpdating = False
> MyCriteria = InputBox("Enter Dept Code")
> If MyCriteria = "" Then Exit Sub
>
> ' Initialize a variable for the last possible record in a worksheet
> If Left(Application.Version, 1) < 8 Then _
> LastRow = 5570 Else LastRow = 65536
>
> With ThisWorkbook
>
> ' Initialize a range object variable for the entire populated
> ' area of column B (excluding row 1 for a header)
> With Worksheets("database")
> Set rCriteriaField = .Range(.Cells(1, 1), _
> .Cells(Application.Max(1, _
> .Cells(LastRow, 1).End(xlUp).Row), 1))
> End With
>
> ' Initialize a range object variable to serve as a pointer
> ' for the records in sheet 2
> Set rCopyTo = .Worksheets("found").Cells(1, 1)
> End With
>
> ' Loop through all the records in your source data table
> For Each rPointer In rCriteriaField
> With rPointer
>
> ' If there is a match on the criteria in col A then copy
> ' the record to the destination table
> If .Value = MyCriteria then
> .Resize(, 5).Copy
> rCopyTo.PasteSpecial xlPasteValues
>
> ' Advance the pointer in your destination table to the
> ' next available row
> Set rCopyTo = rCopyTo.Offset(1, 0)
> End If
> End With
> Next rPointer
> Application.ScreenUpdating = True
> MsgBox "Search Completed"
> End Sub
>
>

Good morning

How about these few lines?

Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="9"
Cells.SpecialCells(xlCellTypeVisible).Copy Sheets(2).Range("A1")

Regards

"Dean" wrote:

> I am having some problems getting the code below to work.
>
> I have a few thousand rows of numbers listed in Column A with a number
> range from 1 to 30. These numbers are spread randomly down the column.
>
> What I am trying to do is search column A for specific instances of
> each number eg 7 and then the code will copy an past those rows
> containing "7" to a sheet labelled "found"
>
> Would appreciate any mods or changes inorder to get this code working.
>
> Kind Regards,
> Dean
>
> Sub Macro2()
>
> Dim LastRow As Long, MyCriteria, _
> rCriteriaField As Range, rPointer As Range, rCopyTo As Range
>
> ' This variable has the value of the criteria by which you intend
> ' to select records to extract. Lets assume you are evaluating
> ' the entries in column A of your source table. This can be either
> ' text or numeric.
> Application.ScreenUpdating = False
> MyCriteria = InputBox("Enter Dept Code")
> If MyCriteria = "" Then Exit Sub
>
> ' Initialize a variable for the last possible record in a worksheet
> If Left(Application.Version, 1) < 8 Then _
> LastRow = 5570 Else LastRow = 65536
>
> With ThisWorkbook
>
> ' Initialize a range object variable for the entire populated
> ' area of column B (excluding row 1 for a header)
> With Worksheets("database")
> Set rCriteriaField = .Range(.Cells(1, 1), _
> .Cells(Application.Max(1, _
> .Cells(LastRow, 1).End(xlUp).Row), 1))
> End With
>
> ' Initialize a range object variable to serve as a pointer
> ' for the records in sheet 2
> Set rCopyTo = .Worksheets("found").Cells(1, 1)
> End With
>
> ' Loop through all the records in your source data table
> For Each rPointer In rCriteriaField
> With rPointer
>
> ' If there is a match on the criteria in col A then copy
> ' the record to the destination table
> If .Value = MyCriteria then
> .Resize(, 5).Copy
> rCopyTo.PasteSpecial xlPasteValues
>
> ' Advance the pointer in your destination table to the
> ' next available row
> Set rCopyTo = rCopyTo.Offset(1, 0)
> End If
> End With
> Next rPointer
> Application.ScreenUpdating = True
> MsgBox "Search Completed"
> End Sub
>
>