我正在尝试从用户提供的日期范围中提取唯一的工作申请编号。将这些唯一的工作请求编号放在J列中（与A列中的WR＃比较后）。然后为列J中找到的每个唯一WR＃（与列A值比较）和第I列中的值添加所有值。对于此计算，我不必显示日期，只需要日期范围的唯一WR＃显示第I列的总和值。例如，如果整个数据集包含2015年1月1日到2015年8月4日的值，并且用户输入的开始日期为2015年7月1日，结束日期为2015年7月31日，唯一值列（＆＃34; J＆＃34;）应仅输出在列I中找到的唯一工作请求值的总和到列K.到目前为止我的努力不成功。代码如下所示，带有数据和代码的excel文件可以从以下链接找到：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
答案 0 :(得分：0)
以下是符合要求的更新代码：
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