Im looking for a code sample that will look at a list in excel and pull
out entire rows based on referenced cell critera and paste those rows
into seperate sheet within the workbook. Anyone have something like
this that they have done before? Any help/direction is greatly
appreciated.

JI wrote:
Im looking for a code sample that will look at a list in excel and pull
out entire rows based on referenced cell critera and paste those rows
into seperate sheet within the workbook. Anyone have something like
this that they have done before? Any help/direction is greatly
appreciated.

The following code does what you've asked, using the spreadsheet the
code is in to determine which rows in the spreadsheet to copy to the
"Top 10" or "Top 21" list. It also uses an imput box for the user to
tell where the rows to be tested start and a simple userform to select
which set of values they want extracted.

Public bTop As Boolean
Public lTop As Long
Public bCancel As Boolean
Sub ExtractTopTen()
Dim wbExtrFrom As Workbook
Dim wsCtyLstTop As Worksheet 'wks where Top 10 list is stored
Dim wsExtFrom As Worksheet 'Wks where data is extracted from
Dim oWS As Object
Dim wsExtrTo As Worksheet

Dim rCopy As Range
Dim rCell As Range 'each cell in rCtyLstTop
Dim rCtyLstTop As Range 'Range on wsCtyLstTop where current
CtyLst is
Dim rFndCell As Range 'Cell found on search for each cty
Dim rExtrFromStrt As Range
Dim rFoundCell As Range
Dim rExtrFrom As Range 'range in Src sheet Where cty names are
Dim rTopSrch As Range
Dim s1stCtyName As String
Dim sUCrCell As String
Dim sCtyName As String
Dim lExtrFromCol As Long 'CtyCol in Src sht
Dim lExtr2Row As Long
Dim lCopyRow As Long
Dim lBOS10Row As Long
Dim lBOS21Row As Long
Dim lStrDif As Long

'Application.ScreenUpdating = False
Set wsCtyLstTop = Workbooks("Mark Top 10.xls").Worksheets("CtyLst")
Set wsExtFrom = ActiveSheet
Set wbExtrFrom = ActiveWorkbook
lBOS10Row = 14
lBOS21Row = 25
bCancel = False

If wbExtrFrom.Name = "Mark Top 10.xls" Then
MsgBox "You have selected the workbook that contains the macro." &
_
Chr(13) & "Please click Ok and select the correct workbook and " &
_
Chr(13) & "worksheet and restart the macro.", vbOKOnly

Exit Sub

End If
'TEST FOR SHEET NAMED "Top"
For Each oWS In wbExtrFrom.Sheets
If oWS.Name = "Top" Then
If MsgBox("A worksheet named Top already exists in this
workbook." _
& Chr(13) & "Please remove or rename it and run the macro
again.", _
vbOKOnly) = vbOK Then Exit Sub
End If
Next

' User inputs cty list location
lExtrFromCol = 0

On Error Resume Next
Set rExtrFromStrt = Application.InputBox _
(prompt:="Please click on the cell where the " & _
"first county is listed.", _
Type:=8, Default:="$a$2")

If rExtrFromStrt Is Nothing Then
Exit Sub 'user hit cancel
End If

s1stCtyName = rExtrFromStrt.Value
lExtrFromCol = rExtrFromStrt.Column
Set rExtrFrom = ActiveSheet.Range(rExtrFromStrt,
rExtrFromStrt.End(xlDown))

If UCase(s1stCtyName) < "ADAMS" Then
If UCase(s1stCtyName) Like "*ADAMS" Then
lStrDif = Len(s1stCtyName) - 5
s1stCtyName = Right(s1stCtyName, Len(s1stCtyName) - lStrDif)
Else
If MsgBox("No ADAMS county found in county list!", vbCancel) _
= vbCancel Then Exit Sub
End If

End If

On Error GoTo 0

frmTopExtractChoose.Show
' bTop from frmTopExtractChoose

If bCancel = True Then Exit Sub

If bTop = False Then
lExtrFromCol = 2

Else
lExtrFromCol = 1

End If

With wsCtyLstTop
Set rCtyLstTop = .Range(.Cells(2, lExtrFromCol), _
.Cells(2, lExtrFromCol).End(xlDown))
End With

'rExtrFrom.Select


wbExtrFrom.Sheets.Add.Activate

ActiveSheet.Name = "Top"
Set wsExtrTo = ActiveSheet
lExtr2Row = 2
If bTop = False Then
wsExtrTo.Range("A1") = "Top 10"
wsExtrTo.Range("A13") = "Balance of State"
Else
wsExtrTo.Range("A1") = "Top 21"
wsExtrTo.Range("A24") = "Balance of State"
End If

wsExtFrom.Activate
rExtrFrom.Activate

For Each rCell In rExtrFrom
lCopyRow = rCell.Row
sCtyName = rCell.Value
If sCtyName = "Total" Or sCtyName = "totals" Then GoTo HappyEnding
sCtyName = Right(sCtyName, Len(sCtyName) - lStrDif)
Set rCopy = wsExtFrom.Rows(lCopyRow)
wsCtyLstTop.Activate
Set rFndCell = rCtyLstTop.Find(what:=sCtyName, _
lookat:=xlPart, _
SearchOrder:=xlByColumns)

If Not rFndCell Is Nothing Then
rCopy.Copy Destination:=wsExtrTo.Rows(lExtr2Row)
lExtr2Row = lExtr2Row + 1
Else
If bTop = False Then
rCopy.Copy Destination:=wsExtrTo.Rows(lBOS10Row)
lBOS10Row = lBOS10Row + 1
Else
rCopy.Copy Destination:=wsExtrTo.Rows(lBOS21Row)
lBOS21Row = lBOS21Row + 1
End If
End If

Next
HappyEnding:
wbExtrFrom.Activate
wsExtrTo.Select
wsExtrTo.UsedRange.Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
End With

Application.ScreenUpdating = True
End Sub 'ExtractTopTen

Hope this helps!

Either sort and copy all at once or
Have a look in vba help index for FIND and FINDNEXT. There is a good
example.

--
Don Guillett
SalesAid Software

"JI" wrote in message
oups.com...
Im looking for a code sample that will look at a list in excel and pull
out entire rows based on referenced cell critera and paste those rows
into seperate sheet within the workbook. Anyone have something like
this that they have done before? Any help/direction is greatly
appreciated.

My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column A:A.
Thanks.

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column A:A.
Thanks.

Wrap-ariound

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy _
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Bob Phillips" wrote in message
...

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column A:A.
Thanks.

I keep getting a compile error and it highlights the first "Cells"
piece of code, any ideas?

Bob Phillips wrote:
Wrap-ariound

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy _
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Bob Phillips" wrote in message
...

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column A:A.
Thanks.

My bad.

iTarget = 7
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A").Value = "All" Then
Cells(i, "B").Resize(, 5).Copy _
Worksheets("Sheet2").Cells(iTarget, "A")
iTarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
I keep getting a compile error and it highlights the first "Cells"
piece of code, any ideas?

Bob Phillips wrote:
Wrap-ariound

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy _
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Bob Phillips" wrote in message
...

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column
A:A.
Thanks.

Works perfectly, Bob your the man...

Bob Phillips wrote:
My bad.

iTarget = 7
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A").Value = "All" Then
Cells(i, "B").Resize(, 5).Copy _
Worksheets("Sheet2").Cells(iTarget, "A")
iTarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
I keep getting a compile error and it highlights the first "Cells"
piece of code, any ideas?

Bob Phillips wrote:
Wrap-ariound

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy _
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Bob Phillips" wrote in message
...

iTarget = 7
For i = 1 To Cells(Rows,Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "All" Then
Cells(i,"B").Resize(,5).Copy
Worksheets("Sheet2").Cells(iTarget,"A")
itarget = iTarget + 1
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"JI" wrote in message
oups.com...
My VBA knowledge isnt up to that level yet, anything more simple you
could show me something that perhaps would look at all the values in
column A:A of "sheet1" if they equaled value "All" then copy columns
B:F on that row and paste it to "sheet2" starting in row 7 column
A:A.
Thanks.