Search code examples
excelvbafor-loopcopy-pastewith-statement

Loop through all cells in a column and copy and paste text if match is found


I am struggling with a simple task. This code currently works:

With ActiveSheet
    Set criteriarange = Range("A1:A" & LShtRow)
        For Each criteriacell In criteriarange
            If Not criteriacell.Value Like "tag:*" Then
                criteriacell.ClearContents
            End If
        Next criteriacell
        For row = LShtRow To 1 Step -1
            With .Cells(row, "B")
                If IsError(Application.Match(.Value, ArrDataNames, 0)) Then .ClearContents
            End With
        Next row
End With

I need to loop through these same cells and look for what I am calling "exceptions." I am putting these exceptions in an array. Currently the array only has one exception and it is "FM" and if it finds "FM" in column "B" row i then I want to copy the text from column "E" row i and paste it to column "H" row i. Here is what I have been trying but it is saying "type mismatch." I am sure it is some simple syntax but i have tried a few things and can't figure it out. Here is my code:

Dim ArrExceptions As Variant
ArrExceptions = Array("FM")

With ActiveSheet
    Set criteriarange = Range("A1:A" & LShtRow)
        For Each criteriacell In criteriarange
            If Not criteriacell.Value Like "tag:*" Then
                criteriacell.ClearContents
            End If
        Next criteriacell
        For row = LShtRow To 1 Step -1
            With .Cells(row, "B")
                If IsError(Application.Match(.Value, ArrDataNames, 0)) Then .ClearContents
            End With
        Next row
'New Code'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        For row = LShtRow To 1 Step -1
                If Application.Match(.Cells(row, "B").Value, ArrExceptions, 0) Then .Range(.Cells(row, "E")).Copy .Range(.Cells(row, "H"))
        Next row
End With

Solution

  • With ActiveSheet
        Set criteriarange = Range("A1:A" & LShtRow)
            For Each criteriacell In criteriarange
                If Not criteriacell.Value Like "tag:*" Then
                    criteriacell.ClearContents
                End If
            Next criteriacell
            For row = LShtRow To 1 Step -1
                With .Cells(row, "B")
                    If IsError(Application.Match(.Value, ArrDataNames, 0)) Then .ClearContents
                End With
            Next row
            For row = LShtRow To 1 Step -1
                    If Not IsError(Application.Match(.Cells(row, "B").Value, ArrExceptions, 0)) Then .Cells(row, "E").Copy .Cells(row, "H")
            Next row
    End With