Looping through data and finding cells that meet criteria

pbarry,

Welcome to the forum!
Have a look here: http://www.excelforum.com/tips-and-t...-criteria.html

Here's the code slightly customized. Note that I set the strCriteriaCol to "C" and I also added a filter for non blanks in column D:

Sub SplitDataIntoSheetsByCriteria()
'Macro created by TigerAvatar at www.excelforum.com, November 2012
'Purpose is to split the data of a sheet into separate sheets based on a key column

    'Declare constants
    'Adjust these to suit your specific needs
    Const strDataSheet As String = "Sheet1"     'The name of the sheet that contains the data
    Const strCriteriaCol As String = "C"        'The letter of the column that will be evaluated
    Const lHeaderRow As Long = 1                'The number of the Header Row
    
    'Declare variables
    Dim ws As Worksheet             'Used to loop through the worksheets in order to alphabetize them
    Dim wsData As Worksheet         'Used to store the Data Sheet to a worksheet object variable
    Dim rngCriteria As Range        'Used to store the Range on the Data Sheet that will be evaluated
    Dim CriteriaCell As Range       'Used to loop through rngCriteria
    Dim lCalc As XlCalculation      'Used to store the current calculation state of the workbook
    Dim strNameWS As String         'Used to create legal worksheet names
    Dim i As Long                   'Generic looping variable
    
    'Set the wsData and rngCriteria variables using the constants declared at the top of this macro
    Set wsData = Sheets(strDataSheet)
    Set rngCriteria = wsData.Range(strCriteriaCol & lHeaderRow, wsData.Cells(Rows.Count, strCriteriaCol).End(xlUp).Offset(, 1))
    
    'Store the current calculation state, set calculation to manual, disable events, alerts, and screenupdating
    'This allows the code to run faster and prevents "screen flickering"
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    'Assume code will fail and provide an error handler
    On Error GoTo CleanExit
    
    'Loop through each cell in rngCriteria
    For Each CriteriaCell In rngCriteria.Resize(, 1).Cells
        'Make sure the cell is after the Header Row
        If CriteriaCell.Row > lHeaderRow Then
            'Make sure the cell is not blank
            If Len(CriteriaCell.Text) > 0 Then
                
                'Generate a legal worksheet name
                strNameWS = CriteriaCell.Text
                For i = 1 To 7
                    strNameWS = Replace(strNameWS, Mid(":\/?*[]", i, 1), " ")
                Next i
                strNameWS = Left(WorksheetFunction.Trim(strNameWS), 31)
                
                'Check if there is already a sheet with the same name
                If Not Evaluate("IsRef('" & strNameWS & "'!A1)") Then
                    'Need to create a new sheet
                    'Add the new sheet, name it appropriately, copy over the information based on the criteria
                    With Sheets.Add(After:=Sheets(Sheets.Count))
                        .Name = strNameWS
                        wsData.Rows(lHeaderRow).EntireRow.Copy .Range("A1")
                        rngCriteria.AutoFilter 1, CriteriaCell.Text 'Filter for the name
                        rngCriteria.AutoFilter 2, "<>"              'Filter for non-blanks
                        rngCriteria.Offset(1).EntireRow.Copy .Range("A2")
                    End With
                End If
            End If
        End If
    Next CriteriaCell
    
    'Set the Data sheet to be the first sheet in the workbook and select that sheet so it is displayed after macro completes
    wsData.Move Before:=Sheets(1)
    wsData.Select
    
'If there were any errors, the code immediately goes here
'The code will also exit here even if there are no errors
CleanExit:
    
    'Remove any remaining filters
    rngCriteria.AutoFilter
    
    'Set calculation back to what it was, re-enable events, alerts, and screenupdating
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    'Display the error that occurred (if any) and clear the error
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object variable cleanup
    Set ws = Nothing
    Set wsData = Nothing
    Set rngCriteria = Nothing
    Set CriteriaCell = Nothing
    
End Sub

Thread moved to appropriate forum.