VBA Shizzle

FilterComments.vba

Sub SeparateCommentsFromActiveSheet()
    SeparateComments (ActiveSheet.Name)
End Sub

Sub SeparateComments(sheetToExamineName As String)
    Set sheetToExamine = ActiveWorkbook.Sheets(sheetToExamineName)

    Dim startingCell As Range
    Dim examineCells As Range
    Dim cell As Range
    Dim filterCell As Range
    Dim filterWordCell As Range
    Dim filterRange As Range
    
    ' filter range is first column of filters worksheet
    Set filterRange = ActiveWorkbook.Sheets("filters").Range(ActiveWorkbook.Sheets("filters").Range("A2"), ActiveWorkbook.Sheets("filters").Range("A2").End(xlDown))
    
    ' this is the starting cell
    Set startingCell = sheetToExamine.Range("A2")
    ' these are the cells that contain comments
    Set examineCells = sheetToExamine.Range(startingCell, startingCell.End(xlDown))
    
    ' now loop through each of the cells
    For Each cell In examineCells.Cells
        For Each filterCell In filterRange.Columns(1).Cells
            Set filterWordCell = filterCell.Next ' should be the cell on the right
            
            Do While filterWordCell.Value <> ""
                
                If InStr(1, cell.Value, filterWordCell.Value, 1) <> 0 Then
                    ' we found the string
                    AddCommentToSheet filterCell.Value, cell.Text
                    Exit Do
                End If
                Set filterWordCell = filterWordCell.Next
            Loop
            
        Next
    Next
    
End Sub

Sub AddCommentToSheet(sheetName As String, comment As String)
    Dim sheet As Worksheet
    
    If WorksheetExists(sheetName) Then
        Set sheet = ActiveWorkbook.Sheets(sheetName)
    Else
        Set sheet = ActiveWorkbook.Sheets.Add
        sheet.Name = sheetName
    End If
    
    If sheet.Range("A1").Value = "" Then
        sheet.Range("A1").Value = comment
    ElseIf sheet.Range("A2").Value = "" Then
        sheet.Range("A2").Value = comment
    Else
        sheet.Range("A1").End(xlDown).Offset(1, 0).Value = comment
    End If
End Sub

' hacky
' http://www.mrexcel.com/forum/showthread.php?t=3228
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

On Error Resume Next
    WorksheetExists = (ActiveWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function