PDA

View Full Version : Sleeper: VBA to Search Word & Concatenate Cell Contents



zest1
10-08-2006, 07:18 PM
Can someone help me with some code that will do the following:
1. SEARCH column A for a particular word (irregular intervals of the word - no set pattern)
2. CONCATENATE the contents of the cell immediately above the found word and with the cell above that
3. DELETE the now empty row of the moved cells and shift cells up
4. LOOP to next instance of search word, etc...

Example:
search word = ?program?
A | B |
1 |
2 | misc. text?
3 | misc. text?
4 | misc. text?
5 | Class #
6 |
etc.

Need this:
A | B |
1 |
2 | misc. text?
3 | misc. text? misc. text?
4 | Class #
5 |
etc...

Thanks for any help

Simon Lloyd
10-09-2006, 04:06 AM
This should do what you want

Sub Macro1()
Dim rng As Range
Dim MyCell
Dim t1
t1 = InputBox("Enter Search Name!", "Word Finder")
Set rng = Range("B1:B10")
For Each MyCell In rng
If MyCell.Text = t1 Then
MyCell.Offset(-2, 0) = MyCell.Offset(-1, 0).Value & " " & MyCell.Offset(-2, 0).Value
MyCell.Select
Selection.Delete Shift:=xlUp
End If
Next
End Sub

Remember if you shift one columns rows up your results for the rest of your worksheet may not be as expected.

Regards,
Simon

P.S dont for get to change the range to suit!

Simon Lloyd
10-09-2006, 04:13 AM
Slight mistake! change the line

MyCell.Select
for

Mycell.OffSet(-1,0).Select

the first line deleted the word you were searching for!

Sorry!
Regards,
Simon

zest1
10-09-2006, 06:26 AM
Simon,
thanks a lot for your help!

I made a few changes to your code, and the following is what I wanted, and works great:

Sub Macro2()
Dim rng As Range
Dim MyCell
Dim t1
t1 = "Class #"
Set rng = Range("A1:A1000")
For Each MyCell In rng
If MyCell.Text = t1 Then
MyCell.Offset(-2, 0) = MyCell.Offset(-2, 0).Value & " - " & MyCell.Offset(-1, 0).Value
MyCell.Offset(-1, 0).EntireRow.Delete Shift:=xlUp
End If
Next
End Sub


One more thing. I'd like to space each group (rows) of "Class #" data groups so that each group consists of 20 rows. Currently, each Class # group has a varying number of rows with a couple empty rows between them. I'd like for the code to count down starting from "Class #" and insert the necessary number of rows until there are 20 rows total for each group. For example:

Class #
1 text
2 text
3 text
4 etc.
(find 1st empty row, and add rows unitl the total rows after 'Class #' = 20 rows)
19 (empty)
20 (empty)
Class #
1
2
3
etc.
20
Class #
1
2
3
etc.
20
etc.

Thanks again for your help :)

Bob Phillips
10-09-2006, 06:26 AM
Sub ConcatenateIt()
Dim cell As Range
Dim sStart As String
Dim rng As Range
With Columns(1)
Set cell = .Find("Bob")
If Not cell Is Nothing Then
If cell.Row > 2 Then
sStart = cell.Address
Do
cell.Offset(-2, 0).Value = cell.Offset(-2, 0).Value & _
cell.Offset(-1, 0).Value
If rng Is Nothing Then
Set rng = cell.Offset(-1, 0)
Else
Set rng = Union(rng, cell.Offset(-1, 0))
End If
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = sStart
End If
End If
End With
If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub

zest1
10-09-2006, 07:47 AM
good alternative - thanks xld.

Now how do I have rows inserted between each group so that each group has 20 rows (as per my last post)?

mdmackillop
10-09-2006, 10:23 AM
Option Explicit
Sub Macro1()
Dim Rw As Long, i As Long, Rws As Long
Rw = 1
Do
Rw = Cells(Rw, 1).End(xlDown).Row + 1
i = i + 1
Rws = 21 * i - Rw
Cells(Rw, 1).Resize(Rws).EntireRow.Insert
Rw = Cells(Rw, 1).End(xlDown).Row
Loop Until Cells(Rw, 1).End(xlDown).Row = Cells.Rows.Count
End Sub

zest1
10-09-2006, 10:35 AM
thanks mdmackillop,
the code generates a runtime error 1004 at the second group of cells.
When I run the code again, it adds more cells to the first group of cells (thus exceeding 20 rows), and then generates the same error 1004 again when getting to the second group.

I think the best way to ensure a total of 20 rows in each group is to use the search word "Class #" as a reference and count down (and ensure) 20 rows from each instance found.

mdmackillop
10-09-2006, 11:23 AM
Can you step through the code and identify the line that creates the error?

zest1
10-09-2006, 11:41 AM
the error occurs at this line:
Cells(Rw, 1).Resize(Rws).EntireRow.Insert

BTW, I should have mentioned that the code does not insert enough rows in the first group (there should be 20 total, but I counted only 16 in all).

thanks

mdmackillop
10-09-2006, 11:59 AM
A slight variation


Option Explicit
Sub Macro1()
Dim Rw As Long, i As Long, Rws As Long
Rw = 1
Do
Rw = Cells(Rw, 1).End(xlDown).Offset.End(xlDown).Row
If Rw = Cells.Rows.Count Then Exit Sub
i = i + 1
Rws = 21 * i - Rw + 1
Cells(Rw, 1).Resize(Rws).EntireRow.Insert
Rw = Cells(Rw, 1).End(xlDown).Row
Loop
End Sub

zest1
10-09-2006, 12:03 PM
no difference

mdmackillop
10-09-2006, 12:48 PM
What version of Excel are you running? Try compiling and see if there are any errors.

Simon Lloyd
10-10-2006, 04:55 AM
MD, i tested your code it worked fine!, it inserts rows after every blank, however your line
Rws = 21 * i - Rw + 1 would need to be
Rws = 23 * i - Rw + 1to actually insert 20 rows, i think you took in to account the start row (haveing data in it) and the last row (which also has data in it).....other than that it worked perfect for every blank that appeared in my series1

regards,
Simon

mdmackillop
10-10-2006, 06:01 AM
Thanks Simon