Excel VBA SUMIF or SUMIFS for multiple criteria

Question

I am trying to pull unique Work Request number from the user’s provided date range. Place these unique work request number in Column J (after comparing with WR# in column A). Then add all values for each Unique WR# found in Column J (comparing with column A values) and with values found in column I. For this calculation I don’t have to show the dates, only need Unique WR# for the date range showing the sum values from column I. For example, if entire data set contains values from January 1, 2015 to August 4, 2015, and the user enter start date as 7/1/2015 and end date as 7/31/2015, the Unique value column ("J") should output only the summation of unique work request's values found in column I into column K. My effort so far is not successful. Code is written below and the excel file with data and code can be found from the following link: https://drive.google.com/file/d/0BzLiHD7QMfVldm1pSG1XaUdpcTQ/view?usp=sharing

Sub SumIfTest()

Worksheets("AccessExtract").Activate

Dim startDate As Date
Dim endDate As Date

startDate = InputBox("Enter Start Date")
endDate = InputBox("Enter End Date")

' Extract unique WR#

Dim d2 As Object, c2 As Variant, i2 As Long, lr2 As Long
Set d2 = CreateObject("Scripting.Dictionary")
lr2 = Cells(Rows.Count, 1).End(xlUp).Row
c2 = Range("A2:A" & lr2)
For i2 = 1 To UBound(c2, 1)
  d2(c2(i2, 1)) = 1
Next i2
Range("J2").Resize(d2.Count) = Application.Transpose(d2.keys)

Dim rowIndex As Long
Dim calcFormula10 As Double

For rowIndex = 2 To lr2

    If ((Cells(rowIndex, "G").Value >= startDate) And (Cells(rowIndex, "G").Value <= endDate)) Then
    calcFormula10 = Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("I:I"))

    End If

Cells(rowIndex, "K").value = calcFormula10

Next rowIndex

End Sub

Answer 1

Here is the updated code that looks like working per the requirements:

Option Explicit

Sub Report1()

Application.DisplayAlerts = False

ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=C:\tmp\ReportLocation\data1.mdb" _
        , _
        "racker.mdb;Mode=Share Deny Write;Extended Properties="""";Jet     OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Databa" _
        , _
        "se Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking     Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bu" _
        , _
        "lk Transactions=1;Jet OLEDB:New Database Password="""";Jet     OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet" _
        , _
        " OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without    Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support C" _
        , _
        "omplex Data=False;Jet OLEDB:Bypass UserInfo Validation=False;Jet   OLEDB:Limited DB Caching=False;Jet OLEDB:Bypass ChoiceField Val" _
        , "idation=False"), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("2015 Activites")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = _
            "C:\tmp\ReportLocation\data1.mdb"
        .ListObject.DisplayName = "Activity_Tracker1"
        .Refresh BackgroundQuery:=False

    End With

' The following code renames the Active sheet to AccessImport
ActiveSheet.Name = "AccessImport"


' ****************************************
' The following code update column G with required Date format

Worksheets("AccessImport").Activate

Range("G:G").NumberFormat = "mm-dd-yyyy"


' Get the start and end date from the user

Dim TheString1 As String, TheString2 As String, TheStartDate As Date,    TheEndDate As Date
Dim TotalDaysEntered As Integer


    TheString1 = Application.InputBox("Enter the start date:")
    TheString2 = Application.InputBox("Enter the end date:")

    If IsDate(TheString1) And IsDate(TheString2) Then
        TheStartDate = DateValue(TheString1)
        TheEndDate = DateValue(TheString2)
    Else
        MsgBox "Invalid date entered"
        Exit Sub
    End If

 ' The following code extracts the data for a specific date range provided by    the user.

     ActiveSheet.ListObjects("Activity_Tracker1").Range.AutoFilter field:=7, Criteria1:=">=" & TheStartDate, Operator:=xlAnd, Criteria2:="<=" & TheEndDate


' Copy data from active sheet to another sheet

ActiveWorkbook.Worksheets.Add
ActiveSheet.Name = "Report1"
Worksheets("AccessImport").Activate

Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
mainworkBook.Sheets("AccessImport").UsedRange.Copy

mainworkBook.Sheets("Report1").Select

mainworkBook.Sheets("Report1").Range("A1").Select

mainworkBook.Sheets("Report1").Paste


' The next block of code fills up all the blank cells found in column A with E4486 or 004486.

Worksheets("Report1").Activate

    Dim c As Integer

    For c = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Range("A" & c).value = vbNullString Then
            Range("A" & c).value = 4486
        End If
    Next c


' Aligning column A to W as Center horizontally.

Columns("A:W").HorizontalAlignment = xlCenter
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit

'Determines the last row that contains data in column A

Dim LastRowFrom As Long
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row


' Find the unique values and place these identified unique values from Column   A into Column J

Dim d2 As Object, c2 As Variant, i2 As Long, lr2 As Long
Set d2 = CreateObject("Scripting.Dictionary")
lr2 = Cells(Rows.Count, 1).End(xlUp).Row
c2 = Range("A2:A" & lr2)
For i2 = 1 To UBound(c2, 1)
  d2(c2(i2, 1)) = 1
Next i2
Range("J2").Resize(d2.Count) = Application.Transpose(d2.keys)

' Calculation

    Dim i As Long
    Dim token As String
    Dim value As Double
Dim lastI As Long
    token = Worksheets(ActiveSheet.Name).Range("A2").value
    value = 0
    For i = 2 To lastRow(ActiveSheet.Name)
        If token = Worksheets(ActiveSheet.Name).Range("A" & CStr(i)).value   Then
            If CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(i)).value) >= TheStartDate And CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(i)).value) <= TheEndDate Then
                value = value + (Worksheets(ActiveSheet.Name).Range("B" & CStr(i)).value + Worksheets(ActiveSheet.Name).Range("C" & CStr(i)).value + Worksheets(ActiveSheet.Name).Range("D" & CStr(i)).value +    Worksheets(ActiveSheet.Name).Range("E" & CStr(i)).value) * 0.008 + 0.08
            End If
        Else

            Worksheets(ActiveSheet.Name).Range("I" & CStr(i - 1)).value = value
            lastI = i
            If CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(i)).value) >= TheStartDate And CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(i)).value) <= TheEndDate Then
                value = (Worksheets(ActiveSheet.Name).Range("B" & CStr(i)).value + Worksheets(ActiveSheet.Name).Range("C" & CStr(i)).value + Worksheets(ActiveSheet.Name).Range("D" & CStr(i)).value + Worksheets(ActiveSheet.Name).Range("E" & CStr(i)).value) * 0.008 + 0.08
            End If
            token = Worksheets(ActiveSheet.Name).Range("A" & CStr(i)).value
        End If
    Next i

    If lastI = lastRow(ActiveSheet.Name) Then
        If CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(lastI)).value) >= TheStartDate And CDate(Worksheets(ActiveSheet.Name).Range("G" & CStr(lastI)).value) <= TheEndDate Then
            value = value + (Worksheets(ActiveSheet.Name).Range("B" & CStr(lastI)).value + Worksheets(ActiveSheet.Name).Range("C" & CStr(lastI)).value + Worksheets(ActiveSheet.Name).Range("D" & CStr(lastI)).value + Worksheets(ActiveSheet.Name).Range("E" & CStr(lastI)).value) * 0.008 + 0.08
        End If
    End If
    Worksheets(ActiveSheet.Name).Range("I" &   CStr(lastRow(ActiveSheet.Name))).value = value * 0.008 + 0.08

' ****************************************
' The following code matches WR # between Column J and A and for the matched  WR# it sums up values in column I.

Dim calcFormula10 As Double
Dim rowIndex As Long

For rowIndex = 2 To lr2


    calcFormula10 = Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("I:I"))


    Cells(rowIndex, "K").value = calcFormula10

Next rowIndex


' Autofit column J, K and L

Columns("J:J").EntireColumn.AutoFit
Columns("K:K").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit

' Inserting title of the columns

Cells(1, "J").value = "WR#"
Cells(1, "K").value = "Total"

' Bolds texts in Cell(1, 10), (1, 11) and (1, 12)

Cells(1, 10).Font.Bold = True
Cells(1, 11).Font.Bold = True
Cells(1, 12).Font.Bold = True

' Hide columns
Columns("A:I").Hidden = True

' Delete empty cells based on values on J column
Dim WS4 As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long

Set WS4 = Worksheets("Report1")

    With WS4
    Set LastCell = .Cells(.Rows.Count, "J").End(xlUp)
    LastCellRowNumber = LastCell.Row
    Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete
End With


End Sub

Private Function lastRow(sheet As String) As Long
    Dim ix As Long
    ix = Worksheets(sheet).UsedRange.Row - 1 + Worksheets(sheet).UsedRange.Rows.Count
    lastRow = ix
End Function