VBA to see if a column contains a certain string

[dpaton05]

I need code to check if a cell in column F contains certain text. I then need to apply colour formatting to the entire row. Can someone help me please?

 

[Michael M]

Maybe like this....but this will colour the "entire" row...do you really want that ??

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "F").End(xlUp).Row
For r = 1 To lr
    If Range("F" & r).Value = "No" Then
       Range("F" & r).EntireRow.Interior.ColorIndex = 3
    End If
Next r
End Sub

 

[lrobbo314]

I would go with conditional formatting on this one.

Let's say that you have data in range A1:F100. And let's imagine that that you have a header row. Let's also say that you have the value that you want to search for in cell H1. Then you would select A2:F100, go to conditional formatting, add a rule, select use a formula, enter this formula =$F2=$H$1, choose whatever format you want, then apply the rule. This way all you have to do is type in a new value into H1 and the new matching rows will be highlighted.

 

[Michael M]

Don't know how many rows you have Dave, this might be quicker

Sub MM2()
With Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
        .AutoFilter Field:=1, Criteria1:="No"
        .Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = 3
        .AutoFilter
    End With
End Sub

 

[dpaton05]

There could be up to 500 rows Michael.

I think I want to go with the vba option. Just trying to work out where to incorporate it into my code. This is my procedure:

Sub cmdCopy()
        Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
        Dim Combo As String, sht As Worksheet, tbl As ListObject
        Dim LastRow As Long, DocYearName As String, lr As Long
        Dim RowColor As Long, w As Window
            Application.ScreenUpdating = False
        'assign values to variables
        Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
        Set sht = ThisWorkbook.Worksheets("Costing_tool")
        For Each tblrow In tbl.ListRows
            If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
                MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
                Exit Sub
            End If
        Next tblrow
        For Each tblrow In tbl.ListRows
            Combo = tblrow.Range.Cells(1, 26).Value
            
                Select Case tblrow.Range.Cells(1, 6).Value
                    Case "Yir"
                        DocYearName = tblrow.Range.Cells(1, 37).Value
                    Case "Ang Wes", "Ang Riv"
                        DocYearName = tblrow.Range.Cells(1, 37).Value
                    Case Else
                        DocYearName = tblrow.Range.Cells(1, 36).Value
                End Select
            If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & DocYearName & ".xlsm"

            Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
             lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
             With wsDst
                    'This copies the first 16 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
                    tblrow.Range.Resize(, 16).Copy
                    'This pastes in the figures in the first 10 columns starting in column A
                    .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                    'Overwrites the numbers pasted to column I with a formula
                    .Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                    'Overwrites the numbers pasted to column J with a formula
                    .Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row).Formula = "=RC[-1]+RC[-2]"
                    'sort procedure copied from vba
                    If .Cells(, 6) = "Yir" Then
                        .Cells.Font.RowColor = -65383
                    End If
                    wsDst.Sort.SortFields.Clear
                    wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).Sort
                                .SetRange Range("A3:AK" & lr)
                                .header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With
            End With
        Next tblrow
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
End Sub

I have inserted an IF statement within the With WsDst but that didn't work.

Where would I include the code to change the colour of the row in the destination workbook if column F of the copied row has the text "Yir"?

Thanks Michael,
Dave

 

[Michael M]

Try inserting here....UNTESTED

Sub cmdCopy()
        Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
        Dim Combo As String, sht As Worksheet, tbl As ListObject
        Dim LastRow As Long, DocYearName As String, lr As Long
        Dim RowColor As Long, w As Window
            Application.ScreenUpdating = False
        'assign values to variables
        Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
        Set sht = ThisWorkbook.Worksheets("Costing_tool")
        For Each tblrow In tbl.ListRows
            If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
                MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
                Exit Sub
            End If
        Next tblrow
        For Each tblrow In tbl.ListRows
            Combo = tblrow.Range.Cells(1, 26).Value
            
                Select Case tblrow.Range.Cells(1, 6).Value
                    Case "Yir"
                        DocYearName = tblrow.Range.Cells(1, 37).Value
                    Case "Ang Wes", "Ang Riv"
                        DocYearName = tblrow.Range.Cells(1, 37).Value
                    Case Else
                        DocYearName = tblrow.Range.Cells(1, 36).Value
                End Select
            If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & DocYearName & ".xlsm"

            Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
             lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
             With wsDst
                    'This copies the first 16 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
                    tblrow.Range.Resize(, 16).Copy
                    'This pastes in the figures in the first 10 columns starting in column A
                    .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                    'Overwrites the numbers pasted to column I with a formula
                    .Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                    'Overwrites the numbers pasted to column J with a formula
                    .Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row).Formula = "=RC[-1]+RC[-2]"
                    'sort procedure copied from vba
                [color=red]With .Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
                        .AutoFilter Field:=1, Criteria1:="Yir"
                        .Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.Interior.Color = -65383
                        .AutoFilter
                End With[/color]
                    wsDst.Sort.SortFields.Clear
                    wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).Sort
                                .SetRange Range("A3:AK" & lr)
                                .header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With
            End With
        Next tblrow
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
End Sub

 

[dpaton05]

Thanks for that Michael, just got a few issues with it.

• I want the text colour to change, not the highlighting
• It appears to change the row colour the first time the procedure is run. If there is additional times it is run, it will not change the colour.

 

[dpaton05]

There could be multiple rows in tblCosting before they are copied across. There could be a row with Yir in column 6, a row with ang wes in column 6 then another row with Yir in it. Only first instance of lines containing the text Yir are highlighted, not the additional line.

 

[Michael M]

I would have thought you would be able to adjust this yourself now Dave !
And you did ask for the entire row to be coloured, not the text.
Ok change the segment to

With .Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
          .AutoFilter Field:=1, Criteria1:="Yir"
          .Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.[color=red]Font[/color].Color = -6538
          .AutoFilter
End With

As for the 2nd issue, it won't "undo" the colouring, but I see no reason why it wouldn't change any additional rows ?

 

[dpaton05]

Thanks for that Michael.

It appears to only change the colour of the first row and if Yir is not in the first row, it could be anywhere, I get an error.