filter/find/highlight/copy/extract a range of data

[martinwroger]

I am importing a text file like the following:

LIN**BP*PN1**PO...
FST*1
FST*1
FST*1
LIN**BP*PN2**PO...
FST*1
FST*1
FST*1
FST*1
LIN**BP*PN3**PO...
FST*1
FST*1
LIN**BP*PN4**PO...
FST*1
FST*1
FST*1
FST*1
FST*1

All data is in column A. Each line that begins with the value LIN**BP*
contains a part number. I have a list of specific part numbers that I
want to use as a filter. I have written a macro to filter the lines
that contain the part number in my filter. The number of lines between
each LIN**BP* varies as shown above.

What I really need is for the macro to also filter/show/highlight/copy
the data underneath as well. For example, using the data above, I want
to filter/find/highlight/copy the list to show only the information
for part number PN1 & PN3. The filtered list would look like this:
LIN**BP*PN1**PO...
FST*1
FST*1
FST*1
LIN**BP*PN3**PO...
FST*1
FST*1

Since the number of lines between each part number line vary, I don't
know how to get started.

Any ideas?

Thanks,

Roger M

XL 2000

 

[OssieMac]

Hi Roger,

I am assuming the the asterisks are wild cards. Is this correct? Should not
matter because Find can handle wildcards. However, in testing for the lines
with FST*1, I have only tested for the left 3 characters "FST".

Not really sure what you mean by show/highlight. I have set the background
color to yellow for the records found. (Highlight could simply mean select
the cells)

Output is to another worksheet.

Anyway try it and see how it goes. Ensure you have a backup of the workbook
in case it does not do what you expect. I left the safetyNet in the loop in
case you have to make alterations. As per the comment, it simply prevents
eternal loops if the developer makes an error in the code.

Note all the comments. You might need to make code adjustments.

Sub FindAndCopy()

Dim rngAllData As Range
Dim rngMyParts As Range
Dim rngPart As Range
Dim rngMyFind As Range
Dim i As Long
Dim safetyNet As Long
Dim strAllDataCol As String
Dim strMyPartsCol As String

'Edit the columns in the following 2 lines _
to suit your worksheet
strAllDataCol = "A" 'Column with all the data
strMyPartsCol = "H" 'Column with required list

'Edit "Sheet1" to suit your worksheet.
With Sheets("Sheet1")
Set rngAllData = Range(.Cells(2, strAllDataCol), _
.Cells(.Rows.Count, strAllDataCol).End(xlUp))
End With

'Edit "Sheet1" to suit your worksheet.
With Sheets("Sheet1")
Set rngMyParts = .Range(.Cells(2, strMyPartsCol), _
.Cells(.Rows.Count, strMyPartsCol).End(xlUp))
End With

For Each rngPart In rngMyParts
'Find each part number in list
Set rngMyFind = rngAllData.Find _
(What:=rngPart.Value, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

i = 0 'initialize.
'i will remain zero if no FST cells and therefore _
the copy range offset will be zero meaning only _
the found cell is copied.

Do
safetyNet = safetyNet + 1 'For preventing eternal loop

'Test next cell for left 3 characters = FST
If Left(rngMyFind.Offset(i + 1, 0), 3) = "FST" Then
i = i + 1
Else
Exit Do 'Exits loop when left 3 characters <> FST
End If
Loop While safetyNet < 1000 'Prevents eternal loop


'Copies and pastes the range to column A of another sheet
'Edit "Sheet2" to suit your workworksheet.
'Edit "A" to place in your required column
Range(rngMyFind, rngMyFind.Offset(i, 0)).Copy _
Sheets("Sheet2").Cells(Rows.Count, "A") _
.End(xlUp).Offset(1, 0)

'Highlight range with background Yellow
Range(rngMyFind, rngMyFind.Offset(i, 0)) _
.Interior.ColorIndex = 6

Next rngPart

End Sub

 

[RogerM]

Hi Roger,

I am assuming the the asterisks are wild cards. Is this correct? Should not
matter because Find can handle wildcards. However, in testing for the lines
with FST*1, I have only tested for the left 3 characters "FST".

Not really sure what you mean by show/highlight. I have set the background
color to yellow for the records found. (Highlight could simply mean select
the cells)

Output is to another worksheet.

Anyway try it and see how it goes. Ensure you have a backup of the workbook
in case it does not do what you expect. I left the safetyNet in the loop in
case you have to make alterations. As per the comment, it simply prevents
eternal loops if the developer makes an error in the code.

Note all the comments. You might need to make code adjustments.

Sub FindAndCopy()

Dim rngAllData As Range
Dim rngMyParts As Range
Dim rngPart As Range
Dim rngMyFind As Range
Dim i As Long
Dim safetyNet As Long
Dim strAllDataCol As String
Dim strMyPartsCol As String

'Edit the columns in the following 2 lines _
 to suit your worksheet
strAllDataCol = "A" 'Column with all the data
strMyPartsCol = "H" 'Column with required list

'Edit "Sheet1" to suit your worksheet.
With Sheets("Sheet1")
    Set rngAllData = Range(.Cells(2, strAllDataCol), _
        .Cells(.Rows.Count, strAllDataCol).End(xlUp))
End With

'Edit "Sheet1" to suit your worksheet.
With Sheets("Sheet1")
    Set rngMyParts = .Range(.Cells(2, strMyPartsCol), _
        .Cells(.Rows.Count, strMyPartsCol).End(xlUp))
End With

For Each rngPart In rngMyParts
    'Find each part number in list
    Set rngMyFind = rngAllData.Find _
    (What:=rngPart.Value, _
    LookIn:=xlFormulas, _
    LookAt:=xlPart, _
    SearchOrder:=xlByColumns, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)

    i = 0   'initialize.
    'i will remain zero if no FST cells and therefore _
     the copy range offset will be zero meaning only _
     the found cell is copied.

    Do
        safetyNet = safetyNet + 1   'For preventing eternal loop

        'Test next cell for left 3 characters = FST
        If Left(rngMyFind.Offset(i + 1, 0), 3) = "FST" Then
            i = i + 1
        Else
            Exit Do 'Exits loop when left 3 characters <> FST
        End If
    Loop While safetyNet < 1000 'Prevents eternal loop

    'Copies and pastes the range to column A of another sheet
    'Edit "Sheet2" to suit your workworksheet.
    'Edit "A" to place in your required column
    Range(rngMyFind, rngMyFind.Offset(i, 0)).Copy _
        Sheets("Sheet2").Cells(Rows.Count, "A") _
            .End(xlUp).Offset(1, 0)

    'Highlight range with background Yellow
    Range(rngMyFind, rngMyFind.Offset(i, 0)) _
        .Interior.ColorIndex = 6

Next rngPart

End Sub

Thanks for the start. Just to clarify, the show/highlight comment can
be read as show OR highlight OR copy etc. which your code does
accomplish. Thanks for the help.

 

[RogerM]

Thanks for the start. Just to clarify, the show/highlight comment can
be read as show OR highlight OR copy etc. which your code does
accomplish. Thanks for the help.

I do have one more question. When the macro searches down AllDataCol
using my list from MyPartsCol, and the search yeilds no results I get
an error "Object variable or With block variable not set" at this line
of the code: If Left(rngMyFind.Offset(i + 1, 0), 3) = "FST" Then
I can't figure out how to get beyond this condition.

Thanks