VBA Compare 2 columns and Return the difference in anoth column

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi I am trying to compare cells in 2 columns and return the value in the 3rd column on the same Row.

This is what I have so far, which is the Ranges I need to use, and have several criteria
Compare each cell between Rng1 and Rng2 and if return the value in the xRng Column if:

-the cell Value in Rng1 is below number 1 then hide that row

-the same number between Rng1 and Rng2 then returned value in xRng column as "0" and turn xRng cell Blue

-the difference is greater in Rng1 than Rng then return the difference and turn xRng cell Red

-the difference is Smaller in Rng1 than Rng then return the difference and turn xRng cell Green


Can someone help with this please

Code:
Option Explicit
Public Fnd As Range, Rng1 As Range, Rng2 As Range, xRng As Range, xVal1 As Range, xVal2 As Range, xVal3 As Range

Sub Total()
     If Range("A1").End(xlToRight) = "Total" Then Exit Sub
     Range("A1").End(xlToRight).Offset(, 1) = "Total"
     Set Rng1 = RngReq
     Set Rng2 = RngIss
     Set xRng = RngTotal
     For Each xVal1 in Rng1
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Compare Columns and Return value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     Next xVal1
End Sub

Function RngReq() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="RequiredQty", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngReq = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function
Function RngIss() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="IssuedQty", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngIss = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function
Function RngTotal() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="Total", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngTotal = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function


Example

Rng1 ColumnRng2 ColumnSome ColumnOther ColumnxRng Column
60300
1000
0.0010
2020

<tbody>
</tbody>

To

Rng1 Column
Rng2 Column
Some Column
Other Column
xRng Column
60
300
240 (Green)
100
0
100 (Red)
20
20
0 (Blue)

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Sorted this now, colors changed from previous post. Code below in case others have the same problem

Code:
Option Explicit
Option Compare Text
Public Fnd As Range, Rng1 As Range, Rng2 As Range, xRng As Range, xVal1 As Range
Sub Total()
     If Range("A1").End(xlToRight) = "Total" Then
          MsgBox "Total Already Exists!"
          Exit Sub
     Else
Call Opt_Start
          Range("A1").End(xlToRight).Offset(, 1) = "Total"
          Set Rng1 = RngReq
          Set Rng2 = RngIss
          Set xRng = RngTotal
          For Each xVal1 In Rng1
               If xVal1.Value < 1 Then
                    xVal1.EntireRow.Hidden = True
               ElseIf xVal1.Value > Cells(xVal1.row, Rng2.Column).Value Then
                    Cells(xVal1.row, xRng.Column).Value = Cells(xVal1.row, Rng2.Column).Value - xVal1.Value
                    Cells(xVal1.row, xRng.Column).Interior.ColorIndex = 3
               ElseIf xVal1.Value < Cells(xVal1.row, Rng2.Column).Value Then
                    Cells(xVal1.row, xRng.Column).Value = Cells(xVal1.row, Rng2.Column).Value - xVal1.Value
                    Cells(xVal1.row, xRng.Column).Interior.ColorIndex = 33
               ElseIf xVal1.Value = Cells(xVal1.row, Rng2.Column).Value Then
                    Cells(xVal1.row, xRng.Column).Value = 0
                    Cells(xVal1.row, xRng.Column).Interior.ColorIndex = 36
               End If
          Next xVal1
     End If
Call Opt_End
End Sub
Function RngReq() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="RequiredQty", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngReq = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function
Function RngIss() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="IssuedQty", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngIss = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function
Function RngTotal() As Range
    Set Fnd = ActiveSheet.Columns.Find(What:="Total", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngTotal = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
        End If
End Function
Public Sub Opt_Start()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
End Sub
Public Sub Opt_End()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,109,543
Messages
5,529,456
Members
409,878
Latest member
DDhol
Top