RE: Re: [ExcelVBA] RE: Using an array to highlight select cells

 

Derek

Your solution tracks my thinking on the solution.

It could be tightened up by loading Array into Dictionary object; removing need for the For-End structure in the  heavily traveled part of the procedure.

db

---In ExcelVBA@yahoogroups.com, <g4swy@...> wrote:

This might be what you want :-

Option Explicit

Sub HighlightIfMatchInArray()

Dim nListindex As Long, vList As Variant

Dim oSheet As Worksheet, rCell As Range, rRangeToSearch As Range

    vList = Array("   Management/Administrators", "   Nursing", "   Health, Professional, Technical", "   Non Management", "   Clerical", "   Allocated/Other Transfers", "   Total Contract Labor FTE")

    For Each oSheet In ActiveWorkbook.Worksheets

        oSheet.Activate

        Set rRangeToSearch = Range("a1", "aa999")

        rRangeToSearch.Interior.Color = xlNone

        For Each rCell In rRangeToSearch.Columns("a").Cells

            For nListindex = 0 To UBound(vList) - 1

                If Trim(rCell.Value) = Trim(vList(nListindex)) Then ' why leading spaces in array ?

                    rRangeToSearch.Rows(rCell.Row).Interior.Color = vbYellow

                    Exit For

                End If

            Next nListindex

        Next rCell

    Next oSheet

End Sub

Regards

Derek Turner

England +++

On Friday, 22 November 2013, 0:41, "dbraithwaite@..." <dbraithwaite@...> wrote:

 

Hi

Not clear what you are trying to do.

Reading between the lines, I think this your problem statement

"For each sheet in the workbook,

Highlight columns A-AA on each row where column A matches one of the items in the array"

Is this what the program is to do ?

db

---In ExcelVBA@yahoogroups.com, <m_bacheldor@...> wrote:

I am hitting a wall on this one. I have an array that I am using to go through a worksheet to select and highlight rows. My problem is that there are two instances of the item in the array and my code only finds the first instance. Second I need to input some error handling so that if the array item is not in the worksheet the code will continue.

 

I am hoping these answers are simple for those of you who program on a regular basis. I have been working on this on need to finish it up but my eyes are crossing. I am pasting the code below.

 

Sub Highlight()
    Dim HighL As Range
   
   
    '.HighL = Worksheet.ActiveCell.Cells(1, 28)
    Range(ActiveCell, ActiveCell.Offset(0, 27)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub
Sub HighlightSelRows()
    Dim vList, lArrCounter As Long, wst As Worksheet
    Dim rngFound As Range, rngToHighlight As Range, sFirstAddress As String
    Dim rngRow As Range
   
    Application.ScreenUpdating = False
   
   
    vList = Array("   Management/Administrators", "   Nursing", "   Health, Professional, Technical", "   Non Management", "   Clerical", "   Allocated/Other Transfers", "   Total Contract Labor FTE")
   
       For Each wst In ActiveWorkbook.Worksheets
            If ActiveWorkbook.Name = "TOC" Then
            Else
            End If
        For lArrCounter = LBound(vList) To UBound(vList)
            With Intersect(wst.UsedRange, wst.Columns("A")) 'wst.UsedRange.Columns("A").Cells
                Set rngFound = .Find( _
                                What:=vList(lArrCounter), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True)
                If Not rngFound Is Nothing Then
                    sFirstAddress = rngFound.Address
                   
                    If rngToHighlight Is Nothing Then
                        Set rngToHighlight = rngFound
                    Else
                        'On Error Resume Next

                        'we can only have one range reference per row.
                        If Intersect(rngToHighlight, rngFound.EntireRow) Is Nothing Then
                            Set rngToHighlight = Union(rngToHighlight, rngFound)
                        End If
                End If
               
                Set rngFound = .FindNext(After:=rngFound)
               
                Do Until rngFound.Address = sFirstAddress
                    If Intersect(rngToHighlight, rngFound.EntireRow) Is Nothing Then
                        Set rngToHighlight = Union(rngToHighlight, rngFound)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
                If rngFound Is Nothing Then
                    'Worksheet.rngFound.Activate
                Else
                    rngFound.Select
                End If
                Call Highlight
        End With
    Next lArrCounter
   
    If Not rngToHighlight Is Nothing Then
        'we can't use a non contigous 3D rrange so we have to delete
        'before looping onto the next worksheet
        'rngToDelete.EntireRow.Delete
        'Application.Cut.Row =CopyMode = False
              

   
        'the referenced range has been disposed; we have to 'clearl the reference to it.
        'before we iterate onto the nextworksheet
        Set rngToDelete = Nothing
    End If

    Next wst
    'If rngFound Is Nothing Then GoTo EndOfProg
EndOfProg:
    Application.ScreenUpdating = True
   
End Sub

 

__._,_.___

Reply via web post

Reply to sender

Reply to group

Start a New Topic

Messages in this topic (4)

Recent Activity:

• New Members 1

Visit Your Group

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------

Switch to: Text-Only, Daily Digest • Unsubscribe • Terms of Use • Send us Feedback

.

__,_._,___