以下是Excel .xlsm文件的链接，该文件包含模块中的代码：https://drive.google.com/file/d/0BzLiHD7QMfVlZlJzS0VTZXNORlU/view?usp=sharing
问题在于如何呈现结果。例如，对于特定的WR＃，结果应为2.104，但计算结果不是。
以下是测试结果doc：https://drive.google.com/file/d/0BzLiHD7QMfVlOVk5Zk13VXdQUlE/view?usp=sharing
此计算的目的是获取每个WR＃的行条目，然后使用公式来总结特定WR＃的值，但结果计算不执行此操作。希望得到任何帮助。
谢谢。
以下是代码：
Option Explicit
Sub DeanRobertReport()
' The following code renames the Active sheet to AccessImport
'ActiveSheet.Name = "AccessImport"
' Activate a sheet
Worksheets("AccessImport").Activate
' 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:")
If IsDate(TheString1) Then
TheStartDate = DateValue(TheString1)
Else
MsgBox "Invalid date entered"
End If
TheString2 = Application.InputBox("Enter the end date:")
If IsDate(TheString2) Then
TheEndDate = DateValue(TheString2)
Else
MsgBox "Invalid date entered"
End If
' TotalDaysEntered = (TheEndDate - TheStartDate) + 1
' The following code extracts the data for a specific date range provided by the user.
ActiveSheet.ListObjects("Table_ARM_Activity_Tracker").Range.AutoFilter field:=7, Criteria1:=">=" & TheStartDate, Operator:=xlAnd, Criteria2:="<=" & TheEndDate
' The next block of code fills up all the blank cells found in column A with E4486 or 004486.
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 = "004486"
End If
Next c
Columns("A:W").HorizontalAlignment = xlCenter
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Long
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
' Copy data from active sheet to another sheet
ActiveWorkbook.Worksheets.Add
ActiveSheet.Name = "DeanRoberts"
Worksheets("AccessImport").Activate
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
mainworkBook.Sheets("AccessImport").UsedRange.Copy
mainworkBook.Sheets("DeanRoberts").Select
mainworkBook.Sheets("DeanRoberts").Range("A1").Select
mainworkBook.Sheets("DeanRoberts").Paste
' Find the unique values and place these identified unique values from Column A into Column J
Worksheets("DeanRoberts").Activate
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)
' Clear contents after the last rows with values in column J
Worksheets("DeanRoberts").Activate
' Sum values found in column B for each unique WR# in Column J, output the result on Column K, L, M, N
Dim rowIndex As Long
Dim calcFormula1 As Double
Dim calcFormula2 As Double
Dim calcFormula3 As Double
Dim calcFormula4 As Double
Dim calcFormula10 As Double
Dim calcFormula20 As Double
Dim calcFormula30 As Double
Dim calcFormula40 As Double
For rowIndex = 2 To lr2
calcFormula10 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("B:B")))
calcFormula20 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("C:C")))
calcFormula30 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("D:D")))
calcFormula40 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("E:E")))
If (calcFormula10 = 0) Then
calcFormula1 = 0
Else
' calcFormula1 = calcFormula10 + 0.08
calcFormula1 = calcFormula10
End If
If (calcFormula20 = 0) Then
calcFormula2 = 0
Else
' calcFormula2 = calcFormula20 + 0.08
calcFormula2 = calcFormula20
End If
If (calcFormula30 = 0) Then
calcFormula3 = 0
Else
' calcFormula3 = calcFormula30 + 0.08
calcFormula3 = calcFormula30
End If
If (calcFormula40 = 0) Then
calcFormula4 = 0
Else
' calcFormula4 = calcFormula40 + 0.08
calcFormula4 = calcFormula40
End If
Cells(rowIndex, "K").Value = calcFormula1
Cells(rowIndex, "L").Value = calcFormula2
Cells(rowIndex, "M").Value = calcFormula3
Cells(rowIndex, "N").Value = calcFormula4
' Cells(rowIndex, "O").Value = ((Cells(rowIndex, "K").Value + Cells(rowIndex, "L").Value + Cells(rowIndex, "M").Value + Cells(rowIndex, "N").Value))
Cells(rowIndex, "O").Value = calcFormula1 + calcFormula2 + calcFormula3 + calcFormula4 + 0.08
Next rowIndex
' Sort values, lowest to highest number WR#
With ActiveWorkbook.Worksheets("DeanRoberts")
With .Cells(2, 10).CurrentRegion
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
End With
Columns("J:J").EntireColumn.AutoFit
Range("O1").Select
Columns("O:O").EntireColumn.AutoFit
Columns("P:P").EntireColumn.AutoFit
' Inserting title of the columns
Cells(1, "J").Value = "WR#"
Cells(1, "K").Value = "Prints"
Cells(1, "L").Value = "Plots"
Cells(1, "M").Value = "Laminate"
Cells(1, "N").Value = "Scans"
Cells(1, "O").Value = "Total Usage"
Cells(1, 10).Font.Bold = True
Cells(1, 11).Font.Bold = True
Cells(1, 12).Font.Bold = True
Cells(1, 13).Font.Bold = True
Cells(1, 14).Font.Bold = True
Cells(1, 15).Font.Bold = True
Cells(1, 16).Font.Bold = True
Cells(1, 17).Font.Bold = True
Cells(1, 18).Font.Bold = True
Columns("A:W").HorizontalAlignment = xlCenter
' Hide multiple column ranges
Columns("A:I").Hidden = True
'Columns("K:N").Hidden = True
Dim WS4 As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
' Delete empty cells based on values on J column
Set WS4 = Worksheets("DeanRoberts")
With WS4
Set LastCell = .Cells(.Rows.Count, "J").End(xlUp)
LastCellRowNumber = LastCell.Row
Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete
End With
'End With
End Sub
答案 0 :(得分：0)
从A1开始，这是我使用的虚假数据：
WR# Prints Plots Lamanatin sqft Scans Dept ID Date Empl
32313 0 8 0 0 PCD 6/24/2015 Dean Robert
35459 1 5 1 1 Net 6/24/2015 Dean Robert
33133 2 6 2 0 Net 6/24/2015 Dean Robert
29985 10 6 3 0 Net 6/24/2015 Dean Robert
22762 5 9 4 2 Net 6/24/2015 Dean Robert
30927 11 1 5 0 Net 6/24/2015 Dean Robert
27530 14 7 6 0 Net 6/24/2015 Dean Robert
35444 9 8 7 3 Net 6/24/2015 Dean Robert
23978 13 2 8 3 Net 6/24/2015 Dean Robert
34645 14 2 9 1 Net 6/24/2015 Dean Robert
29299 1 8 10 0 Net 6/24/2015 Dean Robert
27612 5 3 11 0 Net 6/24/2015 Dean Robert
24938 5 3 12 1 Net 6/24/2015 Dean Robert
26142 1 2 13 2 Net 6/24/2015 Dean Robert
30093 2 5 14 0 Net 6/24/2015 Dean Robert
35578 15 7 15 1 Net 6/24/2015 Dean Robert
32651 8 0 16 2 Net 6/24/2015 Dean Robert
33602 2 5 17 2 Net 6/24/2015 Dean Robert
29629 11 0 18 2 Net 6/24/2015 Dean Robert
29687 2 1 19 2 Net 6/24/2015 Dean Robert
20179 0 1 20 1 Net 6/24/2015 Dean Robert
28558 15 4 21 3 Net 6/24/2015 Dean Robert
33554 13 5 22 1 Net 6/24/2015 Dean Robert
30363 12 7 23 3 Net 6/24/2015 Dean Robert
29145 1 1 24 1 Net 6/24/2015 Dean Robert
35480 11 1 25 1 Net 6/24/2015 Dean Robert
25047 8 7 26 1 Net 6/24/2015 Dean Robert
这是一个子：
Sub DeanRobertReport()
' The following code renames the Active sheet to AccessImport
'ActiveSheet.Name = "AccessImport"
' Activate a sheet
Worksheets("AccessImport").Activate
' 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
Do While Not IsDate(TheString1) 'This will loop until you correctly give a start date
TheString1 = Application.InputBox("Enter the start date:")
Loop
Do While Not IsDate(TheString2)
TheString2 = Application.InputBox("Enter the end date:")
Loop
' The following code extracts the data for a specific date range provided by the user.
ActiveSheet.ListObjects("Table_ARM_Activity_Tracker").Range.AutoFilter field:=7, Criteria1:=">=" & TheStartDate, Operator:=xlAnd, Criteria2:="<=" & TheEndDate
Debug.Print "HI"
' The next block of code fills up all the blank cells found in column A with E4486 or 004486.
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 = "004486"
End If
Next c
Columns("A:W").HorizontalAlignment = xlCenter
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Long
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
' Copy data from active sheet to another sheet
ActiveWorkbook.Worksheets.Add
ActiveSheet.name = "DeanRoberts"
Worksheets("AccessImport").Activate
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
mainworkBook.Sheets("AccessImport").UsedRange.Copy
mainworkBook.Sheets("DeanRoberts").Select
mainworkBook.Sheets("DeanRoberts").Range("A1").Select
mainworkBook.Sheets("DeanRoberts").Paste
' Find the unique values and place these identified unique values from Column A into Column J
Worksheets("DeanRoberts").Activate
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)
' Clear contents after the last rows with values in column J
Worksheets("DeanRoberts").Activate
' Sum values found in column B for each unique WR# in Column J, output the result on Column K, L, M, N
Dim rowIndex As Long
Dim calcFormula1 As Double
Dim calcFormula2 As Double
Dim calcFormula3 As Double
Dim calcFormula4 As Double
Dim calcFormula10 As Double
Dim calcFormula20 As Double
Dim calcFormula30 As Double
Dim calcFormula40 As Double
For rowIndex = 2 To lr2
calcFormula10 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("B:B")))
calcFormula20 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("C:C")))
calcFormula30 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("D:D")))
calcFormula40 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("E:E")))
'Check the values
Debug.Print "calcFormula10: " & calcFormula10
Debug.Print "calcFormula20: " & calcFormula20
Debug.Print "calcFormula30: " & calcFormula30
Debug.Print "calcFormula40: " & calcFormula40
If (calcFormula10 = 0) Then
calcFormula1 = 0
Else
' calcFormula1 = calcFormula10 + 0.08
calcFormula1 = calcFormula10
End If
If (calcFormula20 = 0) Then
calcFormula2 = 0
Else
' calcFormula2 = calcFormula20 + 0.08
calcFormula2 = calcFormula20
End If
If (calcFormula30 = 0) Then
calcFormula3 = 0
Else
' calcFormula3 = calcFormula30 + 0.08
calcFormula3 = calcFormula30
End If
If (calcFormula40 = 0) Then
calcFormula4 = 0
Else
' calcFormula4 = calcFormula40 + 0.08
calcFormula4 = calcFormula40
End If
Cells(rowIndex, "K").Value = calcFormula1
Cells(rowIndex, "L").Value = calcFormula2
Cells(rowIndex, "M").Value = calcFormula3
Cells(rowIndex, "N").Value = calcFormula4
' Cells(rowIndex, "O").Value = ((Cells(rowIndex, "K").Value + Cells(rowIndex, "L").Value + Cells(rowIndex, "M").Value + Cells(rowIndex, "N").Value))
Cells(rowIndex, "O").Value = (calcFormula1 + calcFormula2 + calcFormula3 + calcFormula4) * 0.008 + 0.08
Next rowIndex
' Sort values, lowest to highest number WR#
With ActiveWorkbook.Worksheets("DeanRoberts")
With .Cells(2, 10).CurrentRegion
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
End With
Columns("J:J").EntireColumn.AutoFit
Range("O1").Select
Columns("O:O").EntireColumn.AutoFit
Columns("P:P").EntireColumn.AutoFit
' Inserting title of the columns
Cells(1, "J").Value = "WR#"
Cells(1, "K").Value = "Prints"
Cells(1, "L").Value = "Plots"
Cells(1, "M").Value = "Laminate"
Cells(1, "N").Value = "Scans"
Cells(1, "O").Value = "Total Usage"
For i = 10 To 18 'This will shorten your BOLD code a bit
Cells(1, i).Font.Bold = True
Next i
Columns("A:W").HorizontalAlignment = xlCenter
' Hide multiple column ranges
Columns("A:I").Hidden = True
'Columns("K:N").Hidden = True
Dim WS4 As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
' Delete empty cells based on values on J column
Set WS4 = Worksheets("DeanRoberts")
With WS4
Set LastCell = .Cells(.Rows.Count, "J").End(xlUp)
LastCellRowNumber = LastCell.Row
Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete
End With
'End With
End Sub
你所寻找的距离是多远？
编辑： 更新了类似WR＃s的代码：
Sub DeanRobertReport()
' The following code renames the Active sheet to AccessImport
'ActiveSheet.Name = "AccessImport"
' Activate a sheet
Worksheets("AccessImport").Activate
' 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
Do While Not IsDate(TheString1) 'This will loop until you correctly give a start date
TheString1 = Application.InputBox("Enter the start date:")
Loop
Do While Not IsDate(TheString2)
TheString2 = Application.InputBox("Enter the end date:")
Loop
' The following code extracts the data for a specific date range provided by the user.
' ActiveSheet.ListObjects("Table_ARM_Activity_Tracker").Range.AutoFilter field:=7, Criteria1:=">=" & TheStartDate, Operator:=xlAnd, Criteria2:="<=" & TheEndDate
Debug.Print "HI"
' The next block of code fills up all the blank cells found in column A with E4486 or 004486.
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 = "004486"
End If
Next c
Columns("A:W").HorizontalAlignment = xlCenter
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Long
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
' Copy data from active sheet to another sheet
ActiveWorkbook.Worksheets.Add
ActiveSheet.name = "DeanRoberts"
Worksheets("AccessImport").Activate
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
mainworkBook.Sheets("AccessImport").UsedRange.Copy
mainworkBook.Sheets("DeanRoberts").Select
mainworkBook.Sheets("DeanRoberts").Range("A1").Select
mainworkBook.Sheets("DeanRoberts").Paste
' Find the unique values and place these identified unique values from Column A into Column J
Worksheets("DeanRoberts").Activate
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)
' Clear contents after the last rows with values in column J
Worksheets("DeanRoberts").Activate
' Sum values found in column B for each unique WR# in Column J, output the result on Column K, L, M, N
Dim rowIndex As Long
Dim calcFormula1 As Double
Dim calcFormula2 As Double
Dim calcFormula3 As Double
Dim calcFormula4 As Double
Dim calcFormula10 As Double
Dim calcFormula20 As Double
Dim calcFormula30 As Double
Dim calcFormula40 As Double
For rowIndex = 2 To lr2
calcFormula10 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("B:B")))
calcFormula20 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("C:C")))
calcFormula30 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("D:D")))
calcFormula40 = (Application.SumIf(Range("A:A"), Cells(rowIndex, "J").Text, Range("E:E")))
'Check the values
Debug.Print "calcFormula10: " & calcFormula10
Debug.Print "calcFormula20: " & calcFormula20
Debug.Print "calcFormula30: " & calcFormula30
Debug.Print "calcFormula40: " & calcFormula40
If (calcFormula10 = 0) Then
calcFormula1 = 0
Else
' calcFormula1 = calcFormula10 + 0.08
calcFormula1 = calcFormula10
End If
If (calcFormula20 = 0) Then
calcFormula2 = 0
Else
' calcFormula2 = calcFormula20 + 0.08
calcFormula2 = calcFormula20
End If
If (calcFormula30 = 0) Then
calcFormula3 = 0
Else
' calcFormula3 = calcFormula30 + 0.08
calcFormula3 = calcFormula30
End If
If (calcFormula40 = 0) Then
calcFormula4 = 0
Else
' calcFormula4 = calcFormula40 + 0.08
calcFormula4 = calcFormula40
End If
' Cells(rowIndex, "K").Value = calcFormula1
' Cells(rowIndex, "L").Value = calcFormula2
' Cells(rowIndex, "M").Value = calcFormula3
' Cells(rowIndex, "N").Value = calcFormula4
For i = 11 To 14
Cells(rowIndex, i).Value = Cells(rowIndex, i).Offset(0, -9).Value
Next i
' Cells(rowIndex, "O").Value = ((Cells(rowIndex, "K").Value + Cells(rowIndex, "L").Value + Cells(rowIndex, "M").Value + Cells(rowIndex, "N").Value))
'Cells(rowIndex, "O").Value = (calcFormula1 + calcFormula2 + calcFormula3 + calcFormula4) * 0.008 + 0.08
Cells(rowIndex, "O").Value = WorksheetFunction.Sum(Range(Cells(rowIndex, 11), Cells(rowIndex, 14))) * 0.008 + 0.08
Next rowIndex
' Sort values, lowest to highest number WR#
With ActiveWorkbook.Worksheets("DeanRoberts")
With .Cells(2, 10).CurrentRegion
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
End With
Columns("J:J").EntireColumn.AutoFit
Range("O1").Select
Columns("O:O").EntireColumn.AutoFit
Columns("P:P").EntireColumn.AutoFit
' Inserting title of the columns
Cells(1, "J").Value = "WR#"
Cells(1, "K").Value = "Prints"
Cells(1, "L").Value = "Plots"
Cells(1, "M").Value = "Laminate"
Cells(1, "N").Value = "Scans"
Cells(1, "O").Value = "Total Usage"
'This will shorten your BOLD code a bit
Range(Cells(1, 10), Cells(1, 18)).Font.Bold = True
Columns("A:W").HorizontalAlignment = xlCenter
' Hide multiple column ranges
Columns("A:I").Hidden = True
'Columns("K:N").Hidden = True
Dim WS4 As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
' Delete empty cells based on values on J column
Set WS4 = Worksheets("DeanRoberts")
With WS4
Set LastCell = .Cells(.Rows.Count, "J").End(xlUp)
LastCellRowNumber = LastCell.Row
Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete
End With
'End With
End Sub