Excel VBA SUMIF或SUMIFS多个标准 [英] Excel VBA SUMIF or SUMIFS for multiple criteria

问题描述

我正在尝试从用户提供的日期范围中提取唯一的工作请求号码。将这些独特的工作请求号码放在列J中（与A列中的WR＃进行比较）。然后添加列J中找到的每个Unique WR＃的所有值（与A列值比较）和第一列中找到的值。对于此计算，我不必显示日期，只需要日期范围的唯一WR＃显示第一列的总和值。例如，如果整个数据集包含从2015年1月1日至2015年8月4日的值，并且用户将开始日期作为7/1/2015和结束日期为7/31/2015，唯一值列（J）应仅将列I中找到的唯一工作请求的值的总和输出到列K中。我迄今为止的努力不成功。代码写在下面，并且可以从以下链接找到具有数据和代码的excel文件： https://drive.google.com/file/d/0BzLiHD7QMfVldm1pSG1XaUdpcTQ/view?usp=sharing

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

推荐答案

以下是根据要求进行更新的代码：

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

这篇关于Excel VBA SUMIF或SUMIFS多个标准的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！