VBA Select all cells in column that contain any of these words

[yits05]

Hello,

I have been struggling to figure this out. I have column AA which contains a list of cells. Some of those cells contain specific words, and I would like to select & copy those cells. Here is what I have so far, that is not working:

Dim ranCell As Range
        Dim rRng4 As Range
        Dim lastceAA As Range
        lastceAA = ActiveSheet.Range("AA" & Rows.Count).End(xlUp).Row
            For Each ranCell In Range("AA1" & lastceAA)
                If ranCell.Value = "*January*" Or_
                ranCell.Value = "*February*" Or _
                ranCell.Value = "*March*" Or _
                ranCell.Value = "*April*" Or _
                    ranCell.Value = "*May*" Or _
                    ranCell.Value = "*June*" Or _
                    ranCell.Value = "*July*" Or _
                    ranCell.Value = "*August*" Or _
                    ranCell.Value = "*September*" Or _
                    ranCell.Value = "*October*" Or _
                    ranCell.Value = "*November*" Or _
                    ranCell.Value = "*December" Then
                
                    IrRng4.Select
                    
                    Else
                        Set rRng4 = Application.Union(rRng4, ranCell)
                    End If
                End If
            Next ranCell
           
            Selection.Copy

Any help would be appreciated!

 

[dmt32]

Hi,
see if this update to your code does what you want

Sub CopyCells()
    Dim ranCell     As Range, rRng4 As Range
    Dim lastceAA    As Long
    Dim i           As Integer
    Dim m           As Variant
    Dim ws          As Worksheet
    
    'master sheet - change sheet name as required
    Set ws = Worksheets("Sheet1")
    
    lastceAA = ws.Cells(ws.Rows.Count, "AA").End(xlUp).Row
    
    For Each ranCell In ws.Range("AA1:A" & lastceAA).Cells
        For i = 1 To 12
            m = Application.Match("*" & MonthName(i, False) & "*", Array(ranCell.Value), 0)
            If Not IsError(m) Then
                If rRng4 Is Nothing Then
                    Set rRng4 = ranCell
                Else
                    Set rRng4 = Application.Union(ranCell, rRng4)
                End If
                Exit For
            End If
        Next i
        
    Next ranCell
    
    'copy cells to destination sheet - change as required
    If Not rRng4 Is Nothing Then rRng4.Copy Worksheets("Sheet2").Range("A1")

End Sub

Change sheet names shown in BOLD as required