Macro filter by contains activecell

[mcallaghan]

Hi Guys, macro novice struggling to adapt a macro in an excel doc I inherited. It filters one sheet based on the activecell in another. I'd like to change to filter by whether it CONTAINS the activecell, but when I put ** around activecell in the formula, it just looks for whether it contains the word activecell. Below is the macro I'm using, thanks in advance

Sub FilterPriortyActions()
Dim FilterCrit As String
If ActiveCell = "" Then
MsgBox "The Selected Cell is Blank! Please Select a Cell with a Valid ID from Column A"
Exit Sub
End If
If InRange(ActiveCell, Range("A4:A500")) Then
' code to handle that the active cell is within the right range
FilterCrit = ActiveCell
Sheet8.Cells(1, 2).Value = ActiveSheet.Name
Sheet7.Select
ActiveSheet.Unprotect
With Sheet7
.AutoFilterMode = False
.Range("F3:Y3").AutoFilter
.Range("F3:Y3").AutoFilter Field:=2, Criteria1:=FilterCrit

End With
Else
' code to handle that the active cell is not within the right range
MsgBox "Selected Cell is NOT in the Unique ID column! Please Select a Cell from Column A"
End If

End Sub

 

[FormR]

Try replacing:
FilterCrit = ActiveCell

With:
FilterCrit = "*" & ActiveCell.Value & "*"

 

[mcallaghan]

That's brilliant! Thank you very much, you've saved me so much time!

 

[Iktishaf]

Change the line to
.Range("F3:Y3").AutoFilter Field:=2. Criteria1:="*" & FilterCrit & "*"

By the way, the range in your filter looks strange to me. I would have expected something like "F3:Y500".

 

[mcallaghan]

That was fantastic help guys, now I want to go the other direction. The ActiveCell was a reference, and there are IDs in 6 different tabs, all pointing to the sheet where the filter applied. Field 2 is a list of references, and is being filtered fantastically now.

I'd like a Macro that would find all of the records, from various sheets, that have an ID that is contained in the list of references, and copy them into a new sheet.

So, If the reference cell is "CP001, CP002, R003, M004" (different initials refer to different sheets), I would get each of those records: CP001, CP002 etc., as rows in a new sheet. Nightmare!

If any of you can think of a way, I'll be very impressed!

 

[Iktishaf]

I assume the following:
1. The reference cells always end in 3 digits representing the row in the corresponding sheet.
2. You are going to copy the data into a worksheet called Main, which already exists and is empty.
3. The list of cells from the filter are in column G (i.e. 7).
4. The code is called from the filtered sheet.
Sub CopyOut()
Const MainSheet = "Main", codes = 7
Dim i As Integer, j As Integer, last As Integer, line As Integer, rowno As Integer, _
code As String, sht As String
j = 20
last = Cells(Rows.Count, 7).End(xlUp).Row
line = 0
With Sheets(MainSheet)
For i = 3 To last
If Not Rows(i).Hidden Then
code = Cells(i, codes).Value
sht = Left$(code, Len(code) - 3)
rowno = CInt(Right$(code, 3))
line = line + 1
Sheets(sht).Rows(rowno).Copy Destination:=.Range("A" & line)
End If
Next i
End With
Sheets(MainSheet).Select
End Sub

 

[mcallaghan]

I assume the following:
1. The reference cells always end in 3 digits representing the row in the corresponding sheet.
2. You are going to copy the data into a worksheet called Main, which already exists and is empty.
3. The list of cells from the filter are in column G (i.e. 7).
4. The code is called from the filtered sheet.
Sub CopyOut()
Const MainSheet = "Main", codes = 7
Dim i As Integer, j As Integer, last As Integer, line As Integer, rowno As Integer, _
code As String, sht As String
j = 20
last = Cells(Rows.Count, 7).End(xlUp).Row
line = 0
With Sheets(MainSheet)
For i = 3 To last
If Not Rows(i).Hidden Then
code = Cells(i, codes).Value
sht = Left$(code, Len(code) - 3)
rowno = CInt(Right$(code, 3))
line = line + 1
Sheets(sht).Rows(rowno).Copy Destination:=.Range("A" & line)
End If
Next i
End With
Sheets(MainSheet).Select
End Sub

All good assumptions, but I'm getting a Runtime error 13 Type Mismatch. This line is highlighted on the debugger: rowno = CInt(Right$(code, 3)).

Thanks for your help by the way!

 

[Iktishaf]

That error tells you that my assumption no. 1 is not satisfied. Give me a couple of minutes to send you the revised coding. It's going to be little more involved.

 

[Iktishaf]

Sorry. Access to the Forum has been impossible since my last posting. Here is the revised code.

Sub CopyOut()
Const MainSheet = "Main", codes = 7
Dim i As Integer, last As Integer, line As Integer, ok As Boolean, rowno As Integer, _
tens As Integer, code As String, c As String
last = Cells(Rows.Count, codes).End(xlUp).Row
line = 0
With Sheets(MainSheet)
For i = 3 To last
If Not Rows(i).Hidden Then
code = Cells(i, codes).Value
rowno = 0
tens = 1
Do
c = Right$(code, 1)
ok = (c >= "0") And (c <= "9")
If ok Then
code = Left$(code, Len(code) - 1)
rowno = rowno + (Asc(c) - 48) * tens
tens = tens * 10
End If
Loop While ok
line = line + 1
Sheets(code).Rows(rowno).Copy Destination:=.Range("A" & line)
End If
Next i
End With
End Sub

 

[mcallaghan]

Thanks for your help again. The forum was downso i couldn't get access to it before.

I'm still having problems with your suggestion, and I'm afraid I don't really understand your macro enough to figure out how to sort it out.

I've rephrased my question here http://www.mrexcel.com/forum/excel-questions/701920-copy-if-contains-activecell-componenet.html, and have made some progress and have got a formula that looks for and copies according to the whole activecell, I just need to figure out a way to search for components of the activecell. If you could help, that would be amazing.

Thanks