CODEWITHSUNDEEP
excelvbahighlight
user3461318
user3461318

Reputation: 5

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

Upvotes: 0

Views: 31

Answers (1)

CDP1802
CDP1802

Reputation: 16164

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

Upvotes: 1

Related Questions