Need some advice on the following code

[Dean]

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 = rCopyTffset(1, 0)
End If
End With
Next rPointer
Application.ScreenUpdating = True
MsgBox "Search Completed"
End Sub

 

[Bob Phillips]

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)

 

[Jim Thomlinson]

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...

 

[KC]

Good morning

How about these few lines?

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

Regards