Search code examples
excelvbahighlight

VB Compare 4 Columns of Info with multiple data points then highlight


ColumnsExample I'm trying to compare four columns for information. First Matching Location 1 data to Location 2 data, then comparing the Rented out Columns.

If Location 2 Rented Out Column D (for a specific car that matches column A with Column C) is greater than Rented out Column B then highlight cell (column D) yellow. Also if Rented out Column D

An example pic (ColumnsExample above) would be Honda and Dodge Rented out Column D would be highlighted for failing this.

I'm assuming I'll have to assign Daily, Weekly and Monthly a number value to compare against. Just not sure where to start!

Dim Alert As Range
Dim Daily, Weekly, Monthly As Integer
 Set Daily = 1
 Set Weekly = 2
 Set Monthly = 3
Set ws = ActiveSheet
Set w = ws.Rows(1).Find("Rented Out 2", lookat:=xlWhole)
If Not w Is Nothing Then
For Each Alert In ws.Range(w, ws.Cells(Rows.Count, 
w.Column).End(xlUp)).Cells
        If Alert <= "Daily" Then 
             'Not sure how I can set this condition based on matching 
              'Location 1 with location 2 as well as Rented1 out vs 
              'Rented out 2
            Alert.Interior.Color = 65535
        End If
    Next Alert
End If

Solution

  • Use a Dictionary for the comparison and a Function for the converting the strings to numbers.

    Option Explicit
    
    Sub MyMacro()
    
        Dim ws As Worksheet, iLastRow As Long, r As Long
        Dim dict As Object, key As String, s As String
        Dim i As Integer
        
        Set dict = CreateObject("Scripting.Dictionary")
        Set ws = ActiveSheet
       
        ' scan col A & B
        iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
        For r = 2 To iLastRow
           key = Trim(ws.Cells(r, "A"))
           If Len(key) > 0 Then
               s = Trim(ws.Cells(r, "B"))
               i = TextToNo(s) ' convert text to number
               If i = 0 Then
                   MsgBox "ERROR col B = '" & s & "'", vbCritical, "Row = " & r
                   Exit Sub
               End If
           
               ' add to dictionery
               If dict.exists(key) Then
                   MsgBox "ERROR col A duplicate key = '" & key & "'", vbCritical, "Row = " & r
                   Exit Sub
               Else
                   dict.Add key, i
               End If
           End If
        Next
    
        ' scan col C & D
        iLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
        For r = 2 To iLastRow
           key = Trim(ws.Cells(r, "C"))
           
           If Len(key) > 0 Then
              If dict.exists(key) Then
                  s = Trim(ws.Cells(r, "D"))
                  i = TextToNo(s)
                  If i = 0 Then
                      MsgBox "ERROR col D = '" & s & "'", vbCritical, "Row = " & r
                      Exit Sub
                  End If
                 
                  ' compare col D with col B
                  If i > dict(key) Then
                      ws.Cells(r, "D").Interior.Color = vbYellow
                  Else
                      ws.Cells(r, "D").Interior.Color = vbWhite
                  End If
              End If
           End If
        Next
        MsgBox "Finished"
    
    End Sub
    
    Function TextToNo(s As String) As Integer
        Select Case LCase(s)
            Case "daily": TextToNo = 1
            Case "weekly": TextToNo = 2
            Case "monthly": TextToNo = 3
            Case Else: TextToNo = 0
        End Select
    End Function