VBA - looking through each record

[PrettyMess]

Hi All,

I am struggling a bit with this code, I haven't ever had to reference one column and copy and paste to another tab in VBA so here goes..

I have an excel document with a table on it similar to below:

Colm A Colm B
Nicola Internet
Email
Graham Phone
Email

I need my code to look in column A find the first name in this case Nicola I then want it to look at column B and check to see if she has the word "Internet" appear in any of the records stored against her, as she does the code will ignore her and move down to the next name on the list. In this case Graham it will then look to column B and check if he has the word "Internet" as he doesn't I would then like it to lift the Information from column A & B in relation to this persons name and paste the information into another tab on my workbook.

  Sub Test3()
  Dim x As String
  Dim found As Boolean
  Range("B2").Select
  x = "Internet"
  found = False
  Do Until IsEmpty(ActiveCell)
     If ActiveCell.Value = x Then
        found = True
        Exit Do
     End If
     ActiveCell.Offset(1, 0).Select
  Loop
    If found = False Then
    Sheets("Groupings").Activate
    Sheets("Groupings").Range("A:B").Select
    Selection.Copy
    Sheets("Sheet1").Select
    Sheets("Sheet1").Range("A:B").PasteSpecial

    End If
    End Sub

Any help would be greatly appreciated.

Thanks
Paula

 

[steve the fish]

Can you explain what the 'email' part is? Is each record over two rows or something?

 

[PrettyMess]

Apologies yes each persons name could have multiple rows, it may not just be 2 records against each name

Column A column B
row 1 Nicola......Internet
row 2 ...............Email
row 3 Graham.....Phone
row 4.................Email

 

[steve the fish]

Have a go with this on a copy of your workbook:

Set sh1 = Sheets("Sheet1") 'data sheet
Set sh2 = Sheets("Sheet2") 'paste sheet

lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow '2 being the first row to test
    If Len(sh1.Range("A" & i)) > 0 Then
        Set myfind = Nothing
        
        If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & lastrow)) > 1 Then
            If Len(sh1.Range("A" & i + 1)) = 0 Then
                nextrow = sh1.Range("A" & i).End(xlDown).Row - 1
            Else
                nextrow = nextrow + 1
            End If
            Set myfind = sh1.Range("B" & i, "B" & nextrow).Find(What:="internet", LookIn:=xlFormulas)
        Else
            nextrow = lastrow
            Set myfind = sh1.Range("B" & i, "B" & lastrow).Find(What:="internet", LookIn:=xlFormulas)
        End If
        
        If myfind Is Nothing Then
            sh1.Range("A" & i, "B" & nextrow).Copy
            sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    End If
Next

 

[PrettyMess]

This is practically perfect! however I have one extra small request..... how can I make sure it only finds the word "internet" rather than if the word internet is included in the phrase e.g. Internet_Business and economy

Thanks
Paula

 

[steve the fish]

Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:="internet", LookIn:=xlFormulas, LookAt:=xlWhole)

Try that.

 

[PrettyMess]

That's perfect your a complete legend!

Just wondering for future proofing is there any easy way that I will be able to add another word to this?
e.g. instead of just looking for "internet" I will need to include "non-internet" also at some stage.

 

[steve the fish]

You could by getting the find to search for a variable. Something like:

myVar = sh1.Range("D1")
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)

The code then searches column B for whatever is in D1 of sheet sh1.

 

[PrettyMess]

Thank you very much Steve this worked perfect!