CODEWITHSUNDEEP
vbaexcel
A Cohen
A Cohen

Reputation: 456

VBA - Subtracting varying amount of dates

I am having trouble figuring out how to subtract the very end date of a contract with the beginning date. However, I cannot figure out how to reference the initial date.Example.

For example, =D2 - C2 as well as be able to do =D10 - C5. This is what I currently have, and it does not work at all. 

Dim sla As Long, slacnt As Long, drng As Long, i As Long
i = 2

With Worksheets("Raw")
    slacnt = .Cells(.rows.Count, 2).End(xlUp).Row
    For sla = i To slacnt
        drng = Sheets("Data").Range("B" & i).Value
        If .Range("B" & i) <> .Range("B" & i).Offset(1, 0) Then
        Else: drng = .Range("D" & i).Value - .Range("C" & i).Value
        End If
    Next sla
End With

Image 2

Any direction would be greatly appreciated, thanks in advance.

Upvotes: 0

Views: 97

Answers (2)

SJR
SJR

Reputation: 23081

Vityata has beaten me to it, but I started this so might as well post it.

Sub x()

Dim r As Range, r1 As Range, a, b

With Worksheets("Raw")
    Set r1 = .Range("A2", .Range("D" & Rows.Count).End(xlUp))
End With

With r1.Columns(1)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    For Each r In .SpecialCells(xlCellTypeConstants)
        a = Evaluate("MIN(IF(" & .Address & "=" & r & ",IF(" & r1.Columns(3).Address & "<>""""," & r1.Columns(3).Address & ")))")
        b = Evaluate("MAX(IF(" & .Address & "=" & r & "," & r1.Columns(4).Address & "))")
        r.Offset(, 4) = b - a
    Next r
    .SpecialCells(xlCellTypeFormulas).ClearContents
End With

End Sub

Upvotes: 0

Vityata
Vityata

Reputation: 43575

This would be a perfect problem to be resolved with a dictionary, but somehow I am too lazy to do it this way.

However, let's imagine that all the dates are actually numbers (and in Excel they are!) then your input can be translated to something like this:

enter image description here

What is wanted now is to get the smallest value for each value in column A in column D and the biggest in column E. I have achieved the following:

enter image description here

This is how the code looks like:

Option Explicit

Sub TestMe()

    Dim lngLastRow          As Long
    Dim rngCell             As Range
    Dim rngRange            As Range
    Dim lngMin              As Long
    Dim lngMax              As Long
    Dim lngPreviousRow      As Long
    Dim ws                  As Worksheet

    lngLastRow = lastRow(column_to_check:=2)

    Set ws = ActiveSheet
    Set rngRange = ws.Range(ws.Cells(1, 1), ws.Cells(lngLastRow, 1))

    For Each rngCell In rngRange

        If Len(rngCell) > 0 Then
            If lngPreviousRow > 0 And (rngCell.Row - 1 <> lngPreviousRow) Then
                ws.Cells(lngPreviousRow, 4) = lngMin
                ws.Cells(lngPreviousRow, 5) = lngMax
            End If

            If (rngCell.Row = 1) Or lngPreviousRow = (rngCell.Row - 1) Then
                ws.Cells(rngCell.Row, 4) = WorksheetFunction.Min(rngCell.Offset(0, 1), rngCell.Offset(0, 2))
                ws.Cells(rngCell.Row, 5) = WorksheetFunction.Max(rngCell.Offset(0, 1), rngCell.Offset(0, 2))
            End If

            lngPreviousRow = rngCell.Row
            lngMin = WorksheetFunction.Min(rngCell.Offset(0, 1), rngCell.Offset(0, 2))
            lngMax = WorksheetFunction.Max(rngCell.Offset(0, 1), rngCell.Offset(0, 2))

        Else
            lngMin = WorksheetFunction.Min(lngMin, rngCell.Offset(0, 1), rngCell.Offset(0, 2))
            lngMax = WorksheetFunction.Max(lngMax, rngCell.Offset(0, 1), rngCell.Offset(0, 2))
        End If
    Next rngCell

    Cells(lngPreviousRow, 4) = lngMin
    Cells(lngPreviousRow, 5) = lngMax

End Sub

Function lastRow(Optional strSheet As String, Optional column_to_check As Long = 1) As Long

    Dim shSheet As Worksheet

    If strSheet = vbNullString Then
        Set shSheet = ActiveSheet
    Else
        Set shSheet = Worksheets(strSheet)
    End If

    lastRow = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row

End Function

Points for improvement:

  • WorksheetFunction.Min and WorksheetFunction.Max are repeating 3 times, it would be a good idea to build a separate function for them.
  • simply use a dictionary, it will give a clearer solution. The dictionary should hold an array with two positions, one for the min and one for the max. But it is not as fun as the one above.

Upvotes: 1

Related Questions