J
jjfjr
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 are:
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(ResultsRng), _
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
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 are:
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(ResultsRng), _
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