Solved: Find by phrase

[lukecj]

I am looking for a way to find and paste any cells that contain a certain phrase. For instance, I have a spreadsheet that contains hundreds of different account numbers that all start with the word "Account" followed by the number. From each reference of "Account", I'd like to use offset references to cut and paste certain cells. How do I reference just the "Account" phrase even if the same cell has a number following that reference (so I can do it for every account)? Let me know if this isn't clear. Any help is always appreciated. Thanks.

[lucas]

Since you didn't supply an example and don't tell us which column we can just give you some general advice to get you started I guess.

Use the Like operator. This example looks at column D and deletes all rows with the partial string "labor":


Option Explicit
Option Compare Text
Public Sub DeleteRowsWithLabor()
Const TEST_COLUMN As String = "D" '<=== change to suit
Dim i As Long
Dim iLastRow As Long
With ActiveSheet
'change next line to determine which column to find last row in.
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = iLastRow To 1 Step -1
If .Cells(i, TEST_COLUMN).Value Like "*Labor*" Then
Rows(i).Delete
End If
Next i
End With
End Sub

[Bob Phillips]

Look at Find in VBA Help, and note the values for the LookAt parameter.

[lukecj]

Thanks, Lucas. That gets me started. VBAX - when I search for find in VBA help, the closet I get is LookIn. Thanks for the help.

[Bob Phillips]

In 2003 I types find in the immediate window and F1ed that, and it took me straight there. In 2007 I got many more options first, but Range.Find was the one I was referring to.

[lukecj]

Thanks. Here's the code that I ended up writing...

Sub Sel()

Dim rng As Range, cell As Range, del As Range
Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)

For Each cell In rng
If (cell.Value) Like "*ACCOUNT*" Then

Set del = cell
del.Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1", Range("A65536").End(xlUp)).Offset(1, 0).Select
ActiveSheet.Paste

End If

Sheets("Sheet1").Select

Next cell
On Error Resume Next

End Sub
My question now is how do I change the Range("A1", Range("A65536").End(xlUp)).Offset(1, 0).Select part of the code to select the cell just below the last occupied cell instead of the whole range. You guys are great. Thanks so much.

[lucas]

do you just wish to copy the cell or the entire row?

[lucas]

This uses find and only copies the cell not the row. It can be made to copy the entire row quite easily.

see attached.

Option Explicit
Sub CopyCellsContainingString()
Dim RgToSearch As Range
Dim CharToFind As String
Dim RgDestination As Range
Dim rg As Range

'------ change here ------
Set RgToSearch = ActiveSheet.Range("A:A") 'search in A:A
CharToFind = "account" 'Search for account
Set RgDestination = ActiveWorkbook.Worksheets(2).Range("A65536") _
.End(xlUp).Offset(1, 0) '.EntireRow
'-------------------------

Set rg = FindAll(CharToFind, RgToSearch, xlValues, xlPart, False, False)
If Not rg Is Nothing Then
' rg.EntireRow.Copy RgDestination 'copy resulting rows in RgDestination
rg.Copy RgDestination 'copy resulting cells in RgDestination
End If
End Sub

'---------------------------------------------------------------------------------------------------------------------
'FUNCTION FINDALL : Find all macthing cells and return them into one single range.
' What: what to search for
' Where: range to search
' LookIn: look into xlComments, xlFormulas, or xlValues (default)
' LookAt: look at xlPart (default) or xlWhole
' MatchCase: True or False (default)
' MatchByte: True or False (default)
' Assumes: neither What or Where is Nothing.
Public Function FindAll( _
What As Variant, _
Where As Range, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlPart, _
Optional MatchCase As Boolean = False, _
Optional MatchByte As Boolean = False) As Range
' 2002 - Sebastien Mistouflet
Dim ResultRg As Range
Dim rg As Range
Dim firstAddress As String

With Where
Set rg = .Find(What, LookIn:=LookIn, LookAt:=LookAt, _
MatchCase:=MatchCase, MatchByte:=MatchByte)
If Not rg Is Nothing Then
Set ResultRg = rg
firstAddress = rg.Address
Do
Set ResultRg = Application.Union(ResultRg, rg)
Set rg = .FindNext(rg)
Loop While Not rg Is Nothing And rg.Address <> firstAddress
End If
End With

Set FindAll = ResultRg 'Range to return
End Function

[lukecj]

Just trying to paste the different account numbers into sheet 2. Thanks for the help - this is great.

[lucas]

If your problem is resolved please mark your thread solved using the thread tools at the top of the page.

That keeps others offering help from reading the entire thread just to find that it's already been resolved.

[lukecj]

Is there anyway to have the macro truncate once I get the account numbers into sheet 2. See the attached spreadsheet. Instead of ACCOUNT #<Number>, I would just like to get the <number>. Might be a way to do this when you paste it over.

[GTO]

... From each reference of "Account", I'd like to use offset references to cut and paste certain cells. How do I reference just the "Account" phrase even if the same cell has a number following that reference (so I can do it for every account)? Let me know if this isn't clear. Any help is always appreciated. Thanks.


Is there anyway to have the macro truncate once I get the account numbers into sheet 2. See the attached spreadsheet. Instead of ACCOUNT #<Number>, I would just like to get the <number>. Might be a way to do this when you paste it over.

Greetings Luke,

I see you recently joined; welcome and a friendly Howdy from Arizona.

I sure hope that you take this in the positive light intended. If you can be clearer about the overall goal initially, it can save time for any/all attempting to assist, as, the 'answerer's' suggested method may well cahnge.

I hope that makes sense and again, it is meant in a positive manner.

Okay, so 'ACCOUNT' will be at the front of the cells we want, followed by a space or two... and we would like the number after ACCOUNT; is that correct?

Mark

[lukecj]

Yes. That's correct. I would like the number after ACCOUNT #. Here's the macro I am using. It basically develops the layout of Account numbers I presented in the attached spreadsheet in my last post. I appreciate your response and I will try to make my posts more succinct as I continue to use the forum. It's a huge help.



Sub AccountNumber()

Sheets("Sheet2").Select
Cells.Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
ActiveCell.FormulaR1C1 = "Account Numbers"
Sheets("Sheet1").Select
Range("A1").Select

Dim rng As Range, cell As Range, del As Range
Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)

For Each cell In rng
If (cell.Value) Like "GROSS OF FEES" Then

Set del = cell
del.Offset(2, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").Select
Selection.End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

End If

Sheets("Sheet1").Select

Next cell
On Error Resume Next

End Sub

[GTO]

Well, I am being equally less than complete...sorry.

How many rows of data are we likely to be looping through? A couple hundred, a couple of k, or many thousands?

Mark

[lukecj]

Probably no more than 500 rows...

[lukecj]

Scratch that...It's actually more like 20,000 rows of data that you originally search through...however, only about 500 rows are created from what is searched.

[GTO]

In that case, I might just loop through the cells, but I see no harm in flipping it into an array. I'm very new to regular expressions, but might be worth a try. Similar to Steve's suggestion using Like, but we can replace at the same time.

As you stated to returning the actual numbers, this will drop leading zeros.


Option Explicit

Sub exa()
Dim _
REX As Object, _
aryInData As Variant, _
aryOutData As Variant, _
i As Long

Set REX = CreateObject("VBscript.RegExp")
With REX
.Global = False
.IgnoreCase = True
.Pattern = "\ *ACCOUNT\ *#?"

With ThisWorkbook.Worksheets("Sheet2")
aryInData = Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).Value
End With

ReDim aryOutData(1 To 1, 0 To 0)

For i = 1 To UBound(aryInData, 1)
If .Test(aryInData(i, 1)) Then
ReDim Preserve aryOutData(1 To 1, 1 To UBound(aryOutData, 2) + 1)
aryOutData(1, UBound(aryOutData, 2)) = _
CLng(Trim(.Replace(aryInData(i, 1), vbNullString)))
End If
Next

ThisWorkbook.Worksheets("Sheet3").Range("A2").Resize(UBound(aryOutData, 2)).Value _
= Application.Transpose(aryOutData)
End With
End Sub

Hope that helps,

Mark

[GTO]

ERrr.. Sorry, slow typist. In case we are looking through 20k+ rows, I guessed right; and array will be quicker.

Off to the rack for this lad, a good day to all :-)

Mark

[lukecj]

Thanks, Mark. I really appreciate the help.

[lukecj]

Is there anyway to keep the zeros in the account number? This is awesome.

[GTO]

To treat the numbers as text and keep leading zeros, there's a couple of ways. Here's essentially the same code with a couple of adjustments; as well as being commented, in case this helps while looking through the various related help topics.


Option Explicit

Sub exa()
Dim _
REX As Object, _
aryInData As Variant, _
aryOutData As Variant, _
i As Long

Set REX = CreateObject("VBScript.RegExp")
With REX
'//Check out: http://msdn.microsoft.com/en-us/library/1400241x(VS.85).aspx

'// In gist: Look for our pattern just once per cell (actually, once per element//
'// as we'll use an array). Ignore case so Account would catch as well. If I //
'// have this correct, .Pattern is: zero to many spaces, followed by (fb) //
'// "Account" once, fb zero to many spaces, fb zero to 1 pound/number sign. Of //
'// course the "Account" part is what we are looking for primarily, but the //
'// rest helps us strip (replace) as much as possible, to just leave the number,//
'// and possibly some trailing spaces... //
.Global = False
.IgnoreCase = True
.Pattern = "\ *ACCOUNT\ *#?"

'// We can get rid of Selecting sheets etc, by qualifying the range with what //
'// sheet it belongs to. In this case, we assign the values of cell A2, to the //
'// last row with data in Col A, of Sheet2, to our variant aryInData. Excel //
'// sizes the now array to fit, in a 1 to (however many rows) by 1 to 1 wide //
'// array. //
With ThisWorkbook.Worksheets("Sheet2")
aryInData = Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).Value
End With

'// We want to be able to change the size of our output array on-the-fly. So, //
'// since we can only increase the number of elements of the last dimension, //
'// while preserving the values already added (see vba help, arrays and //
'// Redim Preserve), we size our array to be 1 row, and an adjustable number of //
'// columns. We can transpose it later, to fit how we want to plunk the built //
'// array onto Sheet3. //
ReDim aryOutData(1 To 1, 0 To 0)

'// We use the number of elements in the first dimension of our input array //
'// (that is, the number of rows), to determine how many times to loop. //
For i = 1 To UBound(aryInData, 1)
'// The .Test belongs to REX //
If .Test(aryInData(i, 1)) Then
'// Upon passing .Test, we initially bump the base of our array, and //
'// add an element every time thereafter, thus, sizing the array to just//
'// the size needed to hold our output values. //
ReDim Preserve aryOutData(1 To 1, 1 To UBound(aryOutData, 2) + 1)
'// After replacing what matches our pattern with nothing, we place the //
'// remaining val (the number) into the last current element of our //
'// output array. To retain the leading zeros, I used the apostrophe //
'// prefix. You could alternatively change the number format of the //
'// destination cells. //
aryOutData(1, UBound(aryOutData, 2)) = _
Chr(39) & Trim(.Replace(aryInData(i, 1), vbNullString))
End If
Next
'// Use Resize to size the destination range equal to our built array, and //
'// plunk the transposed array in. //
ThisWorkbook.Worksheets("Sheet3").Range("A2").Resize(UBound(aryOutData, 2)).Value _
= Application.Transpose(aryOutData)
End With
End Sub

Hope that helps,

Mark

[lukecj]

Thanks, Mark...

[GTO]

:beerchug: Happy to help and glad that worked (Shucks, I'm still pretty thrilled to get a RegExp right:cloud9: )


Have a great day,

Mark