VBA to see if a column contains a certain string

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,042
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?
 
Last edited:

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
17,975
Office Version
2013
Platform
Windows
Maybe like this....but this will colour the "entire" row...do you really want that ??

Code:
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

Well-known Member
Joined
Jul 14, 2008
Messages
2,505
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

Well-known Member
Joined
Oct 27, 2005
Messages
17,975
Office Version
2013
Platform
Windows
Don't know how many rows you have Dave, this might be quicker

Code:
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

Well-known Member
Joined
Aug 14, 2018
Messages
1,042
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:

Code:
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

Well-known Member
Joined
Oct 27, 2005
Messages
17,975
Office Version
2013
Platform
Windows
Try inserting here....UNTESTED
Code:
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

Well-known Member
Joined
Aug 14, 2018
Messages
1,042
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

Well-known Member
Joined
Aug 14, 2018
Messages
1,042
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

Well-known Member
Joined
Oct 27, 2005
Messages
17,975
Office Version
2013
Platform
Windows
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

Code:
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

Well-known Member
Joined
Aug 14, 2018
Messages
1,042
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.
 

Forum statistics

Threads
1,078,437
Messages
5,340,275
Members
399,361
Latest member
Linford

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top