Copy entire row based on text in cell to new sheet

[stiggz]

Monthly, I get a CVV of data with associated statistics.
I'm generally only interested in rows with the first cell (A) containing specific words.

The cells (column A) are those such as below:

<table style="border-collapse: collapse; width: 367px; height: 76px;" border="0" cellpadding="0" cellspacing="0"><col style="width: 179pt;" width="238"> <tbody><tr style="height: 15pt;" height="20"> <td style="height: 15pt; width: 179pt;" width="238" height="20">make a webpage free</td> </tr> <tr style="height: 15pt;" height="20"> <td style="height: 15pt;" height="20">create web page free</td> </tr> <tr style="height: 15pt;" height="20"> <td style="height: 15pt;" height="20">make a website with yellow pages
<table style="border-collapse: collapse; width: 179pt;" width="238" border="0" cellpadding="0" cellspacing="0"><col style="width: 179pt;" width="238"><tr style="height: 15pt;" height="20"> <td style="height: 15pt; width: 179pt;" width="238" height="20">how to create web page</td> </tr></table>
</td> </tr> </tbody></table>So, if I wanted to take copy the rows where the cell contains the text 'create web page'. I want it to take 'create web page free' and 'how to create web page' and the cells in their respective row.

I would like these rows to be copied into a new sheet.

I have tried a few similar solutions on here but haven't been able to get any to work. Help much appreciated.

 

[iliace]

First and simplest suggestion: have you tried filtering, where criteria contains your keyword phrase?

 

[stiggz]

First and simplest suggestion: have you tried filtering, where criteria contains your keyword phrase?

Filtering works and is what I have been doing to date, but for what I want to do with the stats I would rather move them into a new worksheet.

 

[iliace]

After you filter, you could copy and paste that to a new sheet. It would make sense to come up with an automated solution if you have more than a few keywords - I'll whip something up tomorrow unless someone beats me to it...

 

[iliace]

This code here assumes the following:

Excel Workbook
	A	B	C	D	E	F	G	H
1
2	make a webpage free	sssssssss	ddddddd	mmmmmm	xxxx	pppp	iiiii	lllllll
3	create web page free	sssss	hhhhhh	aaaa	lllllll	nnnnnnnnn	nnnnnnn	ffffffff
4	make a website with yellow pages	xxxxxxx	rrrrrrrrr	lllllllll	zzzzzzzz	ffff	zzzzz	aaaaaaaa
5	how to create web page	ggggg	ssssss	hhhhhhhh	xxxx	ffffff	ooooooo	tttttttt
6	website building tools	92	99	27	3	21	47	39
data

Excel Workbook
	A
1	Keywords
2	create web page
3	website
keywords

After running this:

Public Sub MatchKeywords()
  Const keySheet As String = "keywords"
  Const dataSheet As String = "data"

  Dim rngKeywords As Excel.Range
  Dim rngSearch As Excel.Range
  Dim rngData As Excel.Range
  Dim rng As Excel.Range
  
  Dim calcs As Excel.XlCalculation
  
  Dim wshResult As Excel.Worksheet
  Dim strSearch As String
  Dim firstFind As String
  
  Application.ScreenUpdating = False
  calcs = Application.Calculation
  Application.Calculation = Excel.xlManual
  
  With ThisWorkbook.Worksheets(keySheet)
    Set rngKeywords = .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
  End With
  
  With ThisWorkbook.Worksheets(dataSheet)
    Set rngData = Intersect(.Columns(1), .UsedRange)
  End With
  
  For Each rng In rngKeywords.Cells
    strSearch = rng.Value
    
    With ThisWorkbook.Worksheets
      Set wshResult = .Add(After:=.Item(.Count))
      wshResult.Range("A1").Value = "Results for """ & strSearch & """"
    End With
    
    wshResult.Name = "Result-" & Left$(strSearch, 24)
    
    Set rngSearch = rngData.Find(strSearch, , Excel.xlFormulas, Excel.xlPart)
    
    If Not rngSearch Is Nothing Then
      firstFind = rngSearch.Address
      Do
        Intersect(rngSearch.EntireRow, rngSearch.Parent.UsedRange).Copy _
                            wshResult.Cells(wshResult.UsedRange.Rows.Count + 1, 1)
        Set rngSearch = rngData.Find(strSearch, rngSearch)
      Loop While Not rngSearch Is Nothing And StrComp(rngSearch.Address, firstFind) <> 0
    End If
  Next rng
  
  Application.ScreenUpdating = True
  Application.Calculation = calcs
End Sub

You get these:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Results for "website"
2	make a website with yellow pages	xxxxxxx	rrrrrrrrr	lllllllll	zzzzzzzz	ffff	zzzzz	aaaaaaaa
3	website building tools	92	99	27	3	21	47	39
Result-website

Excel Workbook
	A	B	C	D	E	F	G	H
1	Results for "create web page"
2	create web page free	sssss	hhhhhh	aaaa	lllllll	nnnnnnnnn	nnnnnnn	ffffffff
3	how to create web page	ggggg	ssssss	hhhhhhhh	xxxx	ffffff	ooooooo	tttttttt
Result-create web page

Post back if this is what you're looking for, or additional info.

 

[stiggz]

Just wanted to say thanks

And for anyone else looking, this worked 100%

 

[Werra2006]

Hello guys

Fantastic piece of work here........I have used the code and developed it to match my specific needs however, I want:

1) to combine the 2 macros into one
2)the code to copy the headers from the data sheet to the created tabs instead of inserting new names.

Here is the code:

Sub OneColumn()
    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("O:O").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("E:Q").Select
    Selection.Delete Shift:=xlToLeft
    Columns("F:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("D7").Select
    MatchKeywords
End Sub
Public Sub MatchKeywords()
  Const keySheet As String = "keywords"
  Const dataSheet As String = "data"
  Dim rngKeywords As Excel.Range
  Dim rngSearch As Excel.Range
  Dim rngData As Excel.Range
  Dim rng As Excel.Range
  
  Dim calcs As Excel.XlCalculation
  
  Dim wshResult As Excel.Worksheet
  Dim strSearch As String
  Dim firstFind As String
  
  Application.ScreenUpdating = False
  calcs = Application.Calculation
  Application.Calculation = Excel.xlManual
  
  With ThisWorkbook.Worksheets(keySheet)
    Set rngKeywords = .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
  End With
  
  With ThisWorkbook.Worksheets(dataSheet)
    Set rngData = Intersect(.Columns(1), .UsedRange)
  End With
  
  For Each rng In rngKeywords.Cells
    strSearch = rng.Value
    
    With ThisWorkbook.Worksheets
      Set wshResult = .Add(After:=.Item(.Count))
      wshResult.Range("A1").Value = "Legal Entity"
      wshResult.Range("B1").Value = "Voucher Number"
      wshResult.Range("C1").Value = "Account"
      wshResult.Range("D1").Value = "Name"
      wshResult.Range("E1").Value = "Date"
      wshResult.Range("F1").Value = "Balance"
      wshResult.Range("G1").Value = "0-30 Days"
      wshResult.Range("H1").Value = "31-60 Days"
      wshResult.Range("I1").Value = "61-90 Days"
      wshResult.Range("J1").Value = "91-120 Days"
      wshResult.Range("K1").Value = "Over 120 Days"
      wshResult.Range("L1").Value = "Comments"
      wshResult.Range("M1").Value = "Actions"
      
    End With
    
    wshResult.Name = Left$(strSearch, 24)
    
    Set rngSearch = rngData.Find(strSearch, , Excel.xlFormulas, Excel.xlPart)
    
    If Not rngSearch Is Nothing Then
      firstFind = rngSearch.Address
      Do
        Intersect(rngSearch.EntireRow, rngSearch.Parent.UsedRange).Copy _
                            wshResult.Cells(wshResult.UsedRange.Rows.Count + 1, 1)
        Set rngSearch = rngData.Find(strSearch, rngSearch)
      Loop While Not rngSearch Is Nothing And StrComp(rngSearch.Address, firstFind) <> 0
    End If
  Next rng
  
  Application.ScreenUpdating = True
  Application.Calculation = calcs
End Sub

 

[iliace]

Some questions. For number one:

1) to combine the 2 macros into one

How do you identify the sheet from which you run the macro? Is it always ActiveSheet?


For number two:

2)the code to copy the headers from the data sheet to the created tabs instead of inserting new names.

What do you mean by "the created tabs"? How do you tell them apart - by worksheet name, data elements, etc? And what do you mean by "new names", are those the new sheets created by the macro?


Note: you don't have to put the two macros into one. In fact, good programming practices suggest that you keep as many separate as you can (the original should have probably been more than one macro, looking back at it after all this time). What you do instead is make all the macros as Private, except the one that you actually run (in your case, OneColumn). This way, it's easy to debug and change the code, but only the main macro appears in the Excel menu when you press Alt+F8, which makes life easier for both the developer and the end user.

Post back with some more details about your specific situation.