I'm not the sharpest knife in the drawer...

[Mattman55]

I have a worksheet of raw data, called Sh1 and one where I want my results, called Parse. I want a simple loop to walk through the rows (column A only) of Sh1, look for a specific word, and return a list of every row and position where that word occurs. This is my first time trying to write VBA code and I've been at it all day. My code is shown below and, yes, I know it's all jacked up. I'm hoping someone on here is willing to help me out. Thanks. -Matthew

Sub finddata()

Dim activityname As String
Dim finalrow As Integer
Dim i As Integer

Sheets("Parse").Range("A2:A20").ClearContents

activityname = Sheets("Parse").Range("A1").Value
finalrow = Sheets("Sh1").Range("A10000").End(xlUp).Row

Worksheets("Sh1").Activate

For i = 2 To finalrow

If InStr("A2:A20", activityname) > 0 Then
Range(Cells(i, 1), Cells(i, 2)).Copy
Else
Range(Cells(i, 1), Cells(i, 1)).Copy
End If

Worksheets("Parse").Activate
Range("P100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats

Next i

End Sub

 

[Joe4]

Welcome to the Board!

Does this modification of your code do what you want?

Sub FindData()

    Dim activityname As String
    Dim finalrow As Long
    Dim i As Long

    Application.ScreenUpdating = False
  
    Sheets("Parse").Range("A2:A20").ClearContents

    activityname = Sheets("Parse").Range("A1").Value
    finalrow = Sheets("Sh1").Cells(Rows.Count, 1).End(xlUp).Row

    Worksheets("Sh1").Activate

    For i = 2 To finalrow
        If InStr(Cells(i, 1), activityname) > 0 Then
            Range(Cells(i, 1), Cells(i, 2)).Copy Sheets("Parse").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next i

    Application.ScreenUpdating = True

End Sub

Also note that "InStr" is case-sensitive (so if you were looking for "dog", it would not find "Dog").
If you want to ignore case, change this line:

If InStr(Cells(i, 1), activityname) > 0 Then

to this:

If InStr(UCase(Cells(i, 1)), UCase(activityname)) > 0 Then

 

[GWteB]

An alternative way of looping through a range of cells ...

Sub Mattman55()

    Dim activityname As String
    Dim finalrow As Integer
    Dim i As Integer
    Dim c As Range

    finalrow = Sheets("Sh1").Range("A10000").End(xlUp).Row

    With Sheets("Parse")

        .Range("A2:A20").ClearContents
    
        activityname = .Range("A1").Value

        For Each c In Worksheets("Sh1").Range("A2:A" & finalrow)

            If InStr(c, activityname) > 0 Then
                c.Copy Destination:=.Range("P100").End(xlUp).Offset(1, 0)
                .Range("P100").End(xlUp).Offset(0, 1) = "row " & c.Row
            Else
                c.Copy Destination:=.Range("P100").End(xlUp).Offset(1, 0)
            End If

        Next c
    End With
End Sub

 

[Trebor76]

Hu Mattman55,

Welcome to MrExcel!!

Here's my attempt:

Option Explicit
Sub FindData()

    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim strActivityName As String
    
    Application.ScreenUpdating = False
    
    With Sheets("Parse")
        lngLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        .Range("A2:A" & lngLastRow).ClearContents
        strActivityName = .Range("A1").Value
    End With
    
    With Sheets("Sh1")
        lngLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For lngMyRow = 2 To lngLastRow
            If Len(.Range("A" & lngMyRow)) > 0 Then 'Ignore empty cells
                If InStr(StrConv(.Range("A" & lngMyRow), vbUpperCase), StrConv(strActivityName, vbUpperCase)) > 0 Then
                    .Range("A" & lngMyRow & ":B" & lngMyRow).Copy
                Else
                    .Range("A" & lngMyRow).Copy
                End If
                'This seems odd in that you're clearing the data from Col. A yet pasting into Col. P of the 'Parse' sheet??
                Sheets("Parse").Range("P" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
            End If
        Next lngMyRow
    End With
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
    MsgBox "Any applicable records have now been copied from sheet ""Sh1"" to sheet ""Parse"".", vbInformation
    
End Sub

Regards,

Robert

regards,

Robert

 

[Joe4]

Note that I noticed a little disconnect between the question and some of the code, so I was working pretty much off of the question (since there are issues with the code).
So if there are other details that were left out of the description, they were left out of the code (I did not want to try to "guess" based on faulty code).

 

[Mattman55]

Welcome to the Board!

Does this modification of your code do what you want?

Sub FindData()

    Dim activityname As String
    Dim finalrow As Long
    Dim i As Long

    Application.ScreenUpdating = False
 
    Sheets("Parse").Range("A2:A20").ClearContents

    activityname = Sheets("Parse").Range("A1").Value
    finalrow = Sheets("Sh1").Cells(Rows.Count, 1).End(xlUp).Row

    Worksheets("Sh1").Activate

    For i = 2 To finalrow
        If InStr(Cells(i, 1), activityname) > 0 Then
            Range(Cells(i, 1), Cells(i, 2)).Copy Sheets("Parse").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next i

    Application.ScreenUpdating = True

End Sub

Also note that "InStr" is case-sensitive (so if you were looking for "dog", it would not find "Dog").
If you want to ignore case, change this line:

If InStr(Cells(i, 1), activityname) > 0 Then

to this:

If InStr(UCase(Cells(i, 1)), UCase(activityname)) > 0 Then

Yes! This worked perfectly. It gave me all the rows that had my word in them. The next person who replied (below) gave me a solution that provided the applicable row numbers, which is also helpful. I think I can combine the codes to get an ideal solution. Thank you, thank you!

 

[Mattman55]

Hu Mattman55,

Welcome to MrExcel!!

Here's my attempt:

Option Explicit
Sub FindData()

    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim strActivityName As String
   
    Application.ScreenUpdating = False
   
    With Sheets("Parse")
        lngLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        .Range("A2:A" & lngLastRow).ClearContents
        strActivityName = .Range("A1").Value
    End With
   
    With Sheets("Sh1")
        lngLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For lngMyRow = 2 To lngLastRow
            If Len(.Range("A" & lngMyRow)) > 0 Then 'Ignore empty cells
                If InStr(StrConv(.Range("A" & lngMyRow), vbUpperCase), StrConv(strActivityName, vbUpperCase)) > 0 Then
                    .Range("A" & lngMyRow & ":B" & lngMyRow).Copy
                Else
                    .Range("A" & lngMyRow).Copy
                End If
                'This seems odd in that you're clearing the data from Col. A yet pasting into Col. P of the 'Parse' sheet??
                Sheets("Parse").Range("P" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
            End If
        Next lngMyRow
    End With
   
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
   
    MsgBox "Any applicable records have now been copied from sheet ""Sh1"" to sheet ""Parse"".", vbInformation
   
End Sub

Regards,

Robert

regards,

Robert

Thank you! I like the MsgBox at the end. It helps to know something has actually happened and the action was performed successfully. I'm going to use parts of this code in conjunction with the other solutions I received. Thank you for taking the time to help me out!

 

[Mattman55]

An alternative way of looping through a range of cells ...

Sub Mattman55()

    Dim activityname As String
    Dim finalrow As Integer
    Dim i As Integer
    Dim c As Range

    finalrow = Sheets("Sh1").Range("A10000").End(xlUp).Row

    With Sheets("Parse")

        .Range("A2:A20").ClearContents
   
        activityname = .Range("A1").Value

        For Each c In Worksheets("Sh1").Range("A2:A" & finalrow)

            If InStr(c, activityname) > 0 Then
                c.Copy Destination:=.Range("P100").End(xlUp).Offset(1, 0)
                .Range("P100").End(xlUp).Offset(0, 1) = "row " & c.Row
            Else
                c.Copy Destination:=.Range("P100").End(xlUp).Offset(1, 0)
            End If

        Next c
    End With
End Sub

Thank you so much!

 

[Joe4]

You are welcome.
Glad we were able to help!