Help to modify this lookup function

[mrmattmc]

I found the below function on this site

http://www.vbaexpress.com/forum/showthread.php?14685-Copy-and-paste-based-on-two-criteria


Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long
With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
If .Cells(i, "A").Value = "Aug" And _
.Cells(i, "B").Value = "salesperson" Then
iTarget = iTarget + 1
.Rows(i).Copy Worksheets("Sheet2").Range("A" & iTarget)
End If
Next i
End With
End Sub
With some slight modifications it seems to do multi criteria lookups well. Unfortunately it doesn't get last row from the destination sheet before doing the copy. It appears as though it is written as if "A" is an empty sheet. Can someone help me to integrate a type
.Cells(.Rows.Count, "A").End(xlUp).Row that doesn't break it? Would also appreciate some pointers on how to transpose this output to columns starting at CL4 with similar columns.count


Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long
With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
If .Cells(i, "A").Value = "Aug" And _
.Cells(i, "B").Value = "Blue" And _
.Cells(i, "G").Value = "Sport" And _
.Cells(i, "W").Value = "salesperson" Then
iTarget = iTarget + 1
.Rows(i).Copy Worksheets("Sheet2").Range("A" & iTarget)
End If
Next i
End With
End Sub

[mancubus]

this is what i use for two criteria. you can add more criteria using the same logic.



Sub test()
With ActiveSheet
.AutoFilterMode = False

.Cells(1).AutoFilter Field:=1, Criteria1:="=Aug"
.Cells(1).AutoFilter Field:=2, Criteria1:="=salesperson"

'Without headers
.UsedRange.Offset(1).SpecialCells(12).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)

'With headers
'.UsedRange.SpecialCells(12).Copy Worksheets("Sheet2").Range("A1")

.AutoFilterMode = False
End With
End Sub

[Paul_Hossler]

FWIW, I use a user defined worksheet function to do multi-criteria MATCH()es


=MatchMulti(TRUE,$A:$A,"DOG",$B:$B,"CAT",$C:$C,"BIRD",$D:$D,"FRED")


I was not sure if you wanted to return the data to a worksheet cell or operate with in within VBA, so I thought I'd put my UDF here in case

Not elegant but I tend towards the KISS principle



Option Explicit
Function MatchMulti(CaseSensitive As Boolean, ParamArray RangesAndValues()) As Variant

Dim i As Long, iRow As Long, iCol As Long
Dim iMatch As Long, iStartRow As Long, iEndRow As Long

'paramarry must be entered
If UBound(RangesAndValues) = -1 Then
MatchMulti = CVErr(xlErrValue)
Exit Function
End If

'must be pairs i.e. last must be odd
If UBound(RangesAndValues) Mod 2 = 0 Then
MatchMulti = CVErr(xlErrValue)
Exit Function
End If

'first of pair must be range
For i = LBound(RangesAndValues) To UBound(RangesAndValues) Step 2
If Not TypeOf RangesAndValues(i) Is Range Then
MatchMulti = CVErr(xlErrValue)
Exit Function
End If
Next i

'second of pair cannot be blank
For i = LBound(RangesAndValues) + 1 To UBound(RangesAndValues) Step 2
If Len(RangesAndValues(i)) = 0 Then
MatchMulti = CVErr(xlErrValue)
Exit Function
End If
Next i

'quick check to make sure there's appropriate data in each match col
For i = LBound(RangesAndValues) To UBound(RangesAndValues) Step 2
On Error Resume Next
iMatch = 0
iMatch = Application.WorksheetFunction.Match(RangesAndValues(i + 1), RangesAndValues(i), 0)
If iMatch = 0 Then
On Error GoTo 0
MatchMulti = CVErr(xlErrNA)
Exit Function
End If
Next i


'case sensitive?
If Not CaseSensitive Then
For i = LBound(RangesAndValues) + 1 To UBound(RangesAndValues) Step 2
RangesAndValues(i) = UCase(RangesAndValues(i))
Next i
End If

'start with first pair (hint to self -- make it the most important)
iStartRow = Application.WorksheetFunction.Match(RangesAndValues(1), RangesAndValues(0), 0)
With RangesAndValues(0)
'is entire column selected
If .Rows.Count = .Parent.Rows.Count Then
iEndRow = .Cells(.Parent.Rows.Count, .Column).End(xlUp).Row
Else
iEndRow = .Cells(.Rows.Count, .Column).Row
End If

'walk up to find lowest match on first parm
iEndRow = iEndRow + 1
Do
iEndRow = iEndRow - 1
Loop Until IIf(CaseSensitive, .Cells(iEndRow, .Column) = RangesAndValues(1), UCase(.Cells(iEndRow, .Column)) = RangesAndValues(1))
End With

'time to the real matching
MatchMulti = CVErr(xlErrNA)
For iRow = iStartRow To iEndRow
For iCol = LBound(RangesAndValues) To UBound(RangesAndValues) Step 2
If CaseSensitive Then
If RangesAndValues(iCol + 1) <> RangesAndValues(iCol).Parent.Cells(iRow, RangesAndValues(iCol).Column).Value Then GoTo NextRow
Else
If RangesAndValues(iCol + 1) <> UCase(RangesAndValues(iCol).Parent.Cells(iRow, RangesAndValues(iCol).Column).Value) Then GoTo NextRow
End If
Next iCol

'found one, the first one
MatchMulti = iRow
Exit Function
NextRow:
Next iRow
End Function

[mrmattmc]

Thanks for the suggestions. I will give them a try tonight when I get back from work

@mancubus can you point me at making this work when row 4 on the source is the headers and columns 1 and 7 are the columns to be filtered?

[mrmattmc]

Thanks to both of you. I adapted mancubus filter routine. Ended up being simple enough. Just like he said. I had tried the autofilter method before but it kept blanking out the source. Got it worked out now.

Used this minor modification to shift down to the header rows at row 4


.Cells(4, 1).AutoFilter Field:=1, Criteria1:=DIS

DIS is a variable I set earlier in the code when the focus was on the destination sheet


Set DIS = Cells.Item(1, 1)

[mrmattmc]

My problem is solved but would still like to know how to modify the original loop to incorporate a last row method for the destination sheet that wont break that original code so if anyone is willing to share I could use to learn something today.

:)

[mancubus]

you're welcome.

so you have found the path yourself. :)

try like:


Public Sub ProcessData()

Dim i As Long
Dim iLastRow As Long

With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
If .Cells(i, "A").Value = "Aug" And .Cells(i, "B").Value = "salesperson" Then
.Rows(i).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End With
End Sub

[mancubus]

autofilter method is very fast, especially, with large data sets.


bonus :D item:

i replaced all VLOOKUP formulas with GETPIVOTDATA formulas in one of my projects. it decreased the code execution time from 4 hours to 1 hour.

[mrmattmc]

I like this shorter version. Allows for it all to be on one line


Public Sub ProcessData()

Dim i As Long
Dim iLastRow As Long

With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
If .Cells(i, "A").Value = "Aug" And .Cells(i, "B").Value = "salesperson"And .Cells(i, "E").Value ="criteria3"And .Cells(i, "W").Value = "Criteria4" Then
.Rows(i).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End With
End Sub

I'm getting ready to dig into the idea of using PasteSpecial with this to see if I can get a Transpose working to dump the output into columns.

Taking it even a step further I have been looking at some of the methods used http://optionexplicitvba.blogspot.com/2012/06/period-table-of-elements-in-excel.html to get the dynamic window type effect.

I'm thinking the autofilter script above populates the table that a version of the rollover script uses to create a dynamic window effect. As my spreadsheet is using a tweaked hyperlink formula it should be easy to modify it if needed to accommodate a more dynamic summary sheet. Although I still prefer click actions to get the new data. The hover effect seems a bit too chaotic.