Hi;

I'm trying to implement a macro to retrieve records from one sheet
based on criteria from another just like the article "An Excel advanced
filter and a macro to extract records from a list" by meadinkent
(http://www.meadinkent.co.uk/xlfilter.htm).

I seem to be able to search on criteria put in any field except one.
When I enter criteria in there even when Iknow I should get some hits,
I don't. My fields a

Location, Section, Shelf, Category, Manufacturer, Manufacturer Number,
Part Serial Number, Item Description, Comment and Condition

It's the section field that doesn't work. MY code looks like this:

Private Sub Clear_Criteria_Click()

CritRng = "B3:K5" ' range of cells for Criteria table
Range(CritRng).ClearContents

End Sub

Private Sub Search_Click()

Dim MaxResults As Integer, MyCol As Integer, ResultsRng As String
Dim MyRow As Integer, LastDataRow As Integer, DataRng As String
Dim CritRow As Integer, CritRng As String, RightCol As Integer
Dim TopRow As Integer, BottomRow As Integer, LeftCol As Integer


' the source data MUST be in a worksheet called 'Data'

' cell Data!E1 contains the last row number of data [=COUNT(E4:E100)+3]


LastDataRow = Worksheets("Data").Range("G1").Value
DataRng = "A2:J2" ' range of column headers for Data table
CritRng = "B3:K5" ' range of cells for Criteria table
ResultsRng = "B8:K8" ' range of headers for Results table
MaxResults = 5000 ' any value higher than the number of possible
results


' fix the data range to incorporate the last row
TopRow = Worksheets("Data").Range(DataRng).Row

LeftCol = Worksheets("Data").Range(DataRng).Column
RightCol = LeftCol + Range(DataRng).Columns.Count - 1
DataRng = Range(Cells(TopRow, LeftCol), Cells(LastDataRow,
RightCol)).Address

' fix the results range to incorporate the last row

TopRow = Worksheets("Data").Range(ResultsRng).Row

LeftCol = Range(ResultsRng).Column
RightCol = LeftCol + Range(ResultsRng).Columns.Count - 1
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults,
RightCol)).Address
Range(ResultsRng).ClearContents ' clear any previous results but not
headers
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults,
RightCol)).Address

' fix the criteria range and identify the last row containing any items

TopRow = Range(CritRng).Row
BottomRow = TopRow + Range(CritRng).Rows.Count - 1
LeftCol = Range(CritRng).Column
RightCol = LeftCol + Range(CritRng).Columns.Count - 1

CritRow = 0

For MyRow = TopRow To BottomRow
For MyCol = LeftCol To RightCol
If Cells(MyRow, MyCol).Value < "" Then CritRow = MyRow
Next
Next

If CritRow = 0 Then
'MsgBox "No Criteria detected"
Else
CritRng = Range(Cells(TopRow - 1, LeftCol), Cells(CritRow,
RightCol)).Address


Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=Worksheets("Results").Range(CritRng ),
CopyToRange:=Worksheets("Results").Range(ResultsRn g), _
Unique:=True
'MsgBox "CriteriaRange= " &
Worksheets("Results").Range(CritRng).Address
'MsgBox "Worksheets(Data).Range(DataRng)=" &
Worksheets("Data").Range(DataRng).Address
End If
Range("A5").Select
End Sub

Any help is greatly
appreciated.
jjfjr

Does the Section criterion work if you apply the filter manually?

jjfjr wrote:
Hi;

I'm trying to implement a macro to retrieve records from one sheet
based on criteria from another just like the article "An Excel advanced
filter and a macro to extract records from a list" by meadinkent
(http://www.meadinkent.co.uk/xlfilter.htm).

I seem to be able to search on criteria put in any field except one.
When I enter criteria in there even when Iknow I should get some hits,
I don't. My fields a

Location, Section, Shelf, Category, Manufacturer, Manufacturer Number,
Part Serial Number, Item Description, Comment and Condition

It's the section field that doesn't work. MY code looks like this:

Private Sub Clear_Criteria_Click()

CritRng = "B3:K5" ' range of cells for Criteria table
Range(CritRng).ClearContents

End Sub

Private Sub Search_Click()

Dim MaxResults As Integer, MyCol As Integer, ResultsRng As String
Dim MyRow As Integer, LastDataRow As Integer, DataRng As String
Dim CritRow As Integer, CritRng As String, RightCol As Integer
Dim TopRow As Integer, BottomRow As Integer, LeftCol As Integer


' the source data MUST be in a worksheet called 'Data'

' cell Data!E1 contains the last row number of data [=COUNT(E4:E100)+3]


LastDataRow = Worksheets("Data").Range("G1").Value
DataRng = "A2:J2" ' range of column headers for Data table
CritRng = "B3:K5" ' range of cells for Criteria table
ResultsRng = "B8:K8" ' range of headers for Results table
MaxResults = 5000 ' any value higher than the number of possible
results


' fix the data range to incorporate the last row
TopRow = Worksheets("Data").Range(DataRng).Row

LeftCol = Worksheets("Data").Range(DataRng).Column
RightCol = LeftCol + Range(DataRng).Columns.Count - 1
DataRng = Range(Cells(TopRow, LeftCol), Cells(LastDataRow,
RightCol)).Address

' fix the results range to incorporate the last row

TopRow = Worksheets("Data").Range(ResultsRng).Row

LeftCol = Range(ResultsRng).Column
RightCol = LeftCol + Range(ResultsRng).Columns.Count - 1
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults,
RightCol)).Address
Range(ResultsRng).ClearContents ' clear any previous results but not
headers
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults,
RightCol)).Address

' fix the criteria range and identify the last row containing any items

TopRow = Range(CritRng).Row
BottomRow = TopRow + Range(CritRng).Rows.Count - 1
LeftCol = Range(CritRng).Column
RightCol = LeftCol + Range(CritRng).Columns.Count - 1

CritRow = 0

For MyRow = TopRow To BottomRow
For MyCol = LeftCol To RightCol
If Cells(MyRow, MyCol).Value < "" Then CritRow = MyRow
Next
Next

If CritRow = 0 Then
'MsgBox "No Criteria detected"
Else
CritRng = Range(Cells(TopRow - 1, LeftCol), Cells(CritRow,
RightCol)).Address


Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy,
_
CriteriaRange:=Worksheets("Results").Range(CritRng ),
CopyToRange:=Worksheets("Results").Range(ResultsRn g), _
Unique:=True
'MsgBox "CriteriaRange= " &
Worksheets("Results").Range(CritRng).Address
'MsgBox "Worksheets(Data).Range(DataRng)=" &
Worksheets("Data").Range(DataRng).Address
End If
Range("A5").Select
End Sub

Any help is greatly
appreciated.
jjfjr



--
Debra Dalgleish
Excel FAQ, Tips & Book List
http://www.contextures.com/tiptech.html